xts/ 0000755 0001762 0000144 00000000000 14703523232 011071 5 ustar ligges users xts/tests/ 0000755 0001762 0000144 00000000000 14702522224 012232 5 ustar ligges users xts/tests/tinytest.R 0000644 0001762 0000144 00000000672 14702522224 014245 0 ustar ligges users # run package unit tests
if (requireNamespace("tinytest", quietly = TRUE)) {
suppressPackageStartupMessages(library("xts"))
use_color <- as.logical(Sys.getenv("_PKG_TINYTEST_COLOR_", FALSE))
verbosity <- as.integer(Sys.getenv("_PKG_TINYTEST_VERBOSE_", 1))
cat("tinytest colored output:", use_color,
"\ntinytest verbosity:", verbosity, "\n")
tinytest::test_package("xts", color = use_color, verbose = verbosity)
}
xts/MD5 0000644 0001762 0000144 00000024262 14703523232 011407 0 ustar ligges users 896fa2f025ba7e4bbfd4a5d9bf3b3110 *DESCRIPTION
8d109e152836d68726ca4ad3a9fcd5ee *NAMESPACE
bf55c9d4b0ab774609f105bb5373ac72 *NEWS.md
13a4d087d20c9296a93a4e7daf48d8be *R/Date.R
9a9e41ee0a003e798ccabff5e10c3b04 *R/Math.xts.R
111bccff1a4d380bff44b14bdff23fa3 *R/OHLC.R
c2ef20cbcbf35a1d1c98d0c50589fe81 *R/Ops.xts.R
187fce032fe9c8b0f2d1617b3a8819e1 *R/POSIX.R
d79b3d7e48a62b93c930de0a71b59c69 *R/adj.time.R
5e30116de2ec1a593ed9b21f50f0c58d *R/align.time.R
719a384387f0229a76a1e28883bdfa62 *R/all.equal.R
69e7d41b342c8b5b5831142207f9e77c *R/as.environment.xts.R
3854d55602258e5e5e2f9c4c165edd33 *R/as.numeric.R
85a4d6658ac4ed00d47939447b14c35b *R/axTicksByTime.R
61c4324133b2263fa9e5a95a898df871 *R/bind.R
1a1014c478e9498604867f18a522cf15 *R/coredata.xts.R
a62e13734091171a8cc697f8d63fb941 *R/data.frame.R
a175decdc727e56ac811c35cb96dcbbe *R/dimnames.R
edc446ca16acada8f0015add2151f68b *R/endpoints.R
2f0b31a5bcd2df6ff3ea4baa7a16b77d *R/first.R
acdda8c521fe61c300fe9866b500db4f *R/index.R
15cef7a8e3232ea1b8515331ca0285af *R/irts.R
6d3b847230363a674d11959938e1be79 *R/isOrdered.R
a55d1464f2877692bffd8dc284052483 *R/lag.xts.R
5b7c1546bcc98af59701cd0a8d210f5b *R/last.R
2b6ac08a19465c8f082b8bda4b543c28 *R/list.R
1b0f3343529429f934b16a714fd1a131 *R/matrix.R
2503ee75bc5ceaeaaba573a8e90058aa *R/merge.R
371654b7ba3f1d48e9c39eea77f4f58f *R/modify.args.R
4d30e9f7f637e4872d0392c0436fb0c4 *R/na.R
365a50fcf07717f387a618fc4edebb7f *R/nperiods.R
f7016e97f94c2bfb2c7ce34877e7f4d5 *R/origin.fix.R
a33c7b4d2606bfde5b3f260f78a1bb02 *R/parse8601.R
f311a96152cc09db7c8e09652e8ee23c *R/period.R
ad50f4ef7687e36f7d329ec16a19cbb9 *R/period.apply.R
0832d8b88027394fb093521164aca44c *R/periodicity.R
c99642a0afe07d468aebec835db3402a *R/plot.R
adb99ee829ce42523e56ce58c6db8036 *R/print.R
587766097ce7edf9ab923b1b0f4a90c3 *R/reclass.R
1517c9051358464b9b0450b4be931c17 *R/rollapply.xts.R
9665fa327a6762098c18cd4c7bfa2c8f *R/split.R
015c507263eb0e0e3382b16f60836bb3 *R/start.R
e80dd17312e93580379a96b81b4b5510 *R/startOfYear.R
8ac7f617f8cc6c11f0e974169d8f42c5 *R/str.R
39d15e2bed04e0d6d698597374d556a0 *R/tclass.R
4fefc28a68ff070d4e3aa3f294949002 *R/tformat.R
dd86b3fdd667b41841f55544f728e64e *R/timeBasedRange.R
4c5e863153e9dc9a8423a0f7814c1de5 *R/timeBasedSeq.R
b2cdfd460e70f9e7e4a810d08cf01a8f *R/timeDate.R
85be96f160431b64f0ef2efe647df272 *R/timeSeries.R
fbbd08e88d7a152f313bc679972ecc17 *R/toperiod.R
b2c1bbf5daa17fad7960ce6b73cf12a7 *R/ts.R
7d7da34e53c6a87bb4764990ef5238d3 *R/tzone.R
d53f58770c0c597019f4f12959e35a54 *R/utils.R
3cb664b4811affcee63d885fdb4719a6 *R/xts-package.R
03dcb034252a8d451a764f7d44f9e8da *R/xts.R
5d9bb181816baae33ef3df318a051f65 *R/xts.methods.R
bfcb5771a061dfd6d6c168be0fd4ef66 *R/yearmon.R
6ed20824a80602ace874fbc43b859902 *R/zoo.R
ac12dbb14b106eed16be76bba725f338 *R/zzz.R
8610078036551f864b330b180a87e2a4 *README.md
2a51be2906d8327018de52b80df9bbd4 *build/vignette.rds
e25f1e32e3b80ef3ff29d103a2c841c9 *data/sample_matrix.rda
d273075b03c4d62b61a42ba4217bf49e *inst/api_example/DESCRIPTION
55d4cc70531955e6a4fd244e7d84c6c1 *inst/api_example/NAMESPACE
6497fbcaf2b3a892cb3dd0776a233dc6 *inst/api_example/R/checkOrder.R
df23f6d544fca7b695962d1f4421bb99 *inst/api_example/README
09118e96879feba050a17474ceff8a8d *inst/api_example/man/checkOrder.Rd
e24ef2161cbc80e1297fe776762ba86d *inst/api_example/man/linkXTS-package.Rd
c0648d7cd58a619e37191ce4f80c6e9f *inst/api_example/src/checkOrder.c
aaa8de0969962f40c9e2d069e115430c *inst/benchmarks/benchmark.subset.R
e45027a27ff403b51af95ea2f1945d95 *inst/doc/xts-faq.R
71177aa2e5c7c8cf3cc3f91b5e635cfe *inst/doc/xts-faq.Rnw
ce79634b8ede1e57d4a3799edeab7c30 *inst/doc/xts-faq.pdf
3d81a4a65b40e6b1cd3cec726449d49d *inst/doc/xts.R
ff730516ee7c76aaabb6b97bbb326b53 *inst/doc/xts.Rnw
e6cb9343ecb1b7604bdfb9695170d975 *inst/doc/xts.pdf
d415cb5e7772a846f462beaeaeb4aebf *inst/include/xts.h
086af5ee3a7aca5dfcaac1096ac4246d *inst/include/xtsAPI.h
fb8b821627015068f6c24f22e183728a *inst/include/xts_stubs.c
ca0456713e0804be8a3c74c37fabd9bd *inst/tinytest/runit.rowSums-rowMeans.R
dce145c15320daf4a6b65e76a9fa5e18 *inst/tinytest/test-Ops.R
e4406914c419f5e370c6481be56b6bb0 *inst/tinytest/test-align.time.R
cb990770472c5bd58bea7ef19624d0d6 *inst/tinytest/test-all.equal.R
9a23ca91be43cb533e70b3ee7125d338 *inst/tinytest/test-binsearch.R
33e1cab561e827bcfc9c7d7668bac885 *inst/tinytest/test-coredata.R
84b4bb6b7855a074d3233a239abc6fc3 *inst/tinytest/test-data.frame.R
5867588c1558b0940d1906fc9ff20097 *inst/tinytest/test-diff.R
ddade7a38f6c21542bdfd50ea2e26915 *inst/tinytest/test-dimnames.R
48a0394f33c87625f436c3af133c07ae *inst/tinytest/test-endpoints.R
e8eb1428568d8bb2ae6e8b37ffb4ed92 *inst/tinytest/test-first-last.R
53d7177c598db078cb35dd52bbed43fb *inst/tinytest/test-index.R
ef46414a4700a955d3b6dd23ef044245 *inst/tinytest/test-irts.R
d1ea8d93f0a9f8ed68d6065262b81f22 *inst/tinytest/test-isordered.R
cf9bfd641615dcb427934adf47859b43 *inst/tinytest/test-lag.R
c95214b252e3204228dd12776b1f8a2c *inst/tinytest/test-matrix.R
5319df2f5cc00d328d464f58e27e4bbd *inst/tinytest/test-merge.R
6d05dc15e012ad76ca468fc08b65c65d *inst/tinytest/test-na.fill.R
c34cbb79cf898c3e4e18cdb993824bd5 *inst/tinytest/test-na.locf.R
57ce6a9082199275ff24c3ab15df05d7 *inst/tinytest/test-na.omit.R
189e95e4940e6ea9fe9464e55f98923b *inst/tinytest/test-parseISO8601.R
ba463b3d1841f34648b1f8e33a91974b *inst/tinytest/test-period.apply.R
939ea7f949fdeae74619591faea3f1f2 *inst/tinytest/test-periodicity.R
70a787661c83533b3f915c36a6e44be4 *inst/tinytest/test-plot.R
082f8b19f7b4e1ce38ca455a1b1d4e05 *inst/tinytest/test-print.R
f1a83dc9f2eaeee878bd7138b2759088 *inst/tinytest/test-reclass.R
b6b66b3cfa0727eaf1def392611bd5d5 *inst/tinytest/test-split.R
270a4ad5c57f259f69244a2f90e40bee *inst/tinytest/test-subset-time-of-day.R
8d7543cb5014325353472f6fdbe4ff2e *inst/tinytest/test-subset.R
917eed127e060a2028d5c653da03f0a2 *inst/tinytest/test-tclass.R
2406e4f31af0d8b18720b19e33a356a9 *inst/tinytest/test-tformat.R
0b700524e0885b162f0536f8c892df63 *inst/tinytest/test-timeBasedSeq.R
db8f51cd33ed4db2c324a95704e5316d *inst/tinytest/test-timeSeries.R
5ef6c25f551d5b7dee43d2ec7182bce7 *inst/tinytest/test-to.period.R
0ef61cea7a0d5818d57a84be6557d253 *inst/tinytest/test-ts.R
71a0014e95a45208e500ae88ccdd2809 *inst/tinytest/test-tzone.R
866a2d8b6ec3fa41316727f3366597d1 *inst/tinytest/test-xts.R
3f2a81d0c93d39369ad40fde049b5c57 *inst/tinytest/test-xts.methods.R
c55d666140103d930dcd40754a28dd3c *inst/tinytest/test-zoo.R
0fca212ba456c3993191f3b18cd41b4a *man/CLASS.Rd
9bd5f4a6241f497f60a2a8e07e9eaa48 *man/addEventLines.Rd
7c16ff70f9e563555085a6447517fc4d *man/addLegend.Rd
a2a5d513493e88e4db004ab9860e5188 *man/addPanel.Rd
15e5bfc37bba693bcdf55416cf37d8b9 *man/addPolygon.Rd
4554dd68ce6833f01b23a5d4c4aec4b5 *man/addSeries.Rd
211b22b5c985f96dc7248b2a20ed654c *man/align.time.Rd
9f1e893b1c0d1a43ffce5236ce725359 *man/apply.monthly.Rd
754a2b311c832d96a4519e261f51bc47 *man/as.environment.xts.Rd
ec5ca7a5f1fe83bee2e5219c7a9f251e *man/as.xts.Rd
01cd14a3e920251beb58aa9876ab21bb *man/axTicksByTime.Rd
aaf5dd3389385a04c16a1698208b17a8 *man/coredata.xts.Rd
8a803fcd5b39753706b655e43db0defd *man/diff.xts.Rd
f260f3946100bbed3ee52ec37fdbeed1 *man/dimnames.xts.Rd
a1b3867b33361972d4927d1dff0d5f1e *man/endpoints.Rd
a1260ca32c2ec63d4eda7044284f4fbb *man/first.Rd
9001160596bf7fb42b2954de8d1ac4e4 *man/firstof.Rd
c013c792539377623137797077ce516f *man/index.xts.Rd
ca4105116cc570760f1332167078b495 *man/isOrdered.Rd
3d7690ea93f681bde0b44de136388227 *man/make.index.unique.Rd
96f15c80498132cebadd903eb041fb9d *man/merge.xts.Rd
b9efca06212de054c15037af26f31e57 *man/na.locf.xts.Rd
cacfffc5e4946902fc0e3659f415844b *man/ndays.Rd
4fc896dab44c718a075e897a4df3280d *man/parseISO8601.Rd
58288fa74051abebbb9f20d946727f65 *man/period.apply.Rd
7201acae67a0cefc4b613f65ead0ed10 *man/period_math.Rd
71875c7f7b461b1b28a9272de416bcd4 *man/periodicity.Rd
dceb0782ff76a34641720c2a2d6182fc *man/plot.xts.Rd
becbb33ddcbc405d82ce9a1d8a3ed838 *man/print.xts.Rd
f8298a87d8208fbc2f405affc28d80e6 *man/rbind.xts.Rd
e4e1421d9f034eb2253b5d54e30ff653 *man/reclass.Rd
03bfabb3754364845f6b6d262d5fbd83 *man/sample.data.Rd
11a2562aa4804cce38362f5fd77ca7e3 *man/split.xts.Rd
7bc9167cd9971127480369f517be7ccd *man/subset.xts.Rd
f551c16ce8192173d38359c689f6f5e0 *man/tclass.Rd
5e5a59e254e1c7a4656f92cb6b793d33 *man/tformat.Rd
5b158dfbd2d354c73eb8f623983c7d16 *man/timeBased.Rd
20bcba1ebebadffa3d7b34b1ed59b87b *man/timeBasedSeq.Rd
626c294bd8cf5bf889e0438f4862b838 *man/to.period.Rd
14868cc17a2908eacc75935aedfd8213 *man/tzone.Rd
2bfdc0f8e2ebb0b54d17d01bce764000 *man/window.xts.Rd
2929e244a621384bbc08a79fe3b11621 *man/xts-internals.Rd
bd9168fb6aee9477153d3954ac8f007d *man/xts-package.Rd
cd8ba60d194ecedf2d8c862f27dbcd3e *man/xts.Rd
afc7f16f7f8aac67c7e2067d41fcba2d *man/xtsAPI.Rd
6f32697828e85b03121a85f26c04bb3e *man/xtsAttributes.Rd
3f03da795dd26373156bddc78d41e95d *src/Makevars
3f03da795dd26373156bddc78d41e95d *src/Makevars.win
6b0374aa67a0cb5dd38f879e708132b4 *src/add_class.c
f485a4c5521e77204579b020f825bccc *src/any.c
352b7b0f1c8c49702baf9945fd20ff5f *src/attr.c
d1eb6437796db5e54605264b1f3548cc *src/binsearch.c
c91fe2075d20c8cf572452b7a69d4f5c *src/coredata.c
c9aa1258d5793b5bde6e98974b9700b1 *src/dimnames.c
4d148e934a4f7b8c13d06f356f79e246 *src/endpoints.c
56be552537e6dfb9e4cd32adf66d2522 *src/extract_col.c
f76f72c7348fe190d1b22376df918d9a *src/init.c
5a1131c5c4cda826587411b399762e94 *src/isOrdered.c
6406378662cae4ddb780b572e3c207f5 *src/isXts.c
76eef6c210f46da6f0f43f388096b1a7 *src/lag.c
b1c669347285967a1dd0b282ef0ed09c *src/merge.c
100daa62d01821334ed99b3d5a0667b2 *src/na.c
da1b6df2c0b5b64c331335cf525dc143 *src/period_apply.c
98c3542c73b9d2e3bcb0874c93c199c8 *src/period_arithmetic.c
9d155812d858824aed442e88555e4e27 *src/period_quantile.c
1d7cd5483505427cfd2e6776e14d571f *src/rbind.c
7a60c01780f630c072175e7134ef08d9 *src/rollfun.c
b6339594a3cf5d8dde13a6f9f771187c *src/runSum.c
e0c8a91a3f89dc44f3d3033a3c7c8335 *src/startofyear.c
8b82aa3c1336652137236dfbdce1123c *src/subset.c
215a490e1edcdbf627eea9fe03f5359b *src/subset.old.c
0139eb8441e8dffcfc001dc33b1986e4 *src/toperiod.c
8b6df2194602bcec234c8840a3121e3e *src/totalcols.c
4c2811f9dd0f501b9105838cd78c2652 *src/tryXts.c
ddcf2148cb8071a63182c5721e80b404 *src/unique.time.c
74a087b663e6fb7a2eaec9ec333120b6 *src/xts.c
72514cfd44456eea7b95ba4701c92887 *tests/tinytest.R
71177aa2e5c7c8cf3cc3f91b5e635cfe *vignettes/xts-faq.Rnw
ff730516ee7c76aaabb6b97bbb326b53 *vignettes/xts.Rnw
xts/R/ 0000755 0001762 0000144 00000000000 14703504524 011275 5 ustar ligges users xts/R/tzone.R 0000644 0001762 0000144 00000015422 14702273721 012564 0 ustar ligges users #
# 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 2 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 .
#' @rdname tzone
indexTZ <- function(x, ...)
{
.Deprecated("tzone", "xts")
tzone(x, ...)
}
#' Get or Replace the Timezone of an xts Object's Index
#'
#' Generic functions to get or replace the timezone of an xts object's index.
#'
#' Internally, an xts object's index is a *numeric* value corresponding to
#' seconds since the epoch in the UTC timezone. When an xts object is created,
#' all time index values are converted internally to [`POSIXct()`]
#' (which is also in seconds since the UNIX epoch), using the underlying OS
#' conventions and the \env{TZ} environment variable. The `xts()` function
#' manages timezone information as transparently as possible.
#'
#' The `tzone<-` function *does not* change the internal index values
#' (i.e. the index will remain the same time in the UTC timezone).
#'
#' @param x An xts object.
#' @param value A valid timezone value (see [`OlsonNames()`]).
#' @param \dots Arguments passed to other methods.
#'
#' @return A one element named vector containing the timezone of the object's
#' index.
#'
#' @note Both `indexTZ()` and `indexTZ<-` are deprecated in favor of
#' `tzone()` and `tzone<-`, respectively.
#'
#' Problems may arise when an object that had been created under one timezone
#' are used in a session using another timezone. This isn't usually a issue,
#' but when it is a warning is given upon printing or subsetting. This warning
#' may be suppressed by setting `options(xts_check_TZ = FALSE)`.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`index()`][xts::index.xts] has more information on the xts index, [`tformat()`]
#' describes how the index values are formatted when printed, and [`tclass()`]
#' provides details how \pkg{xts} handles the class of the index.
#'
#' @keywords ts utilities
#' @examples
#'
#' # Date indexes always have a "UTC" timezone
#' x <- xts(1, Sys.Date())
#' tzone(x)
#' str(x)
#' print(x)
#'
#' # The default 'tzone' is blank -- your machine's local timezone,
#' # determined by the 'TZ' environment variable.
#' x <- xts(1, Sys.time())
#' tzone(x)
#' str(x)
#'
#' # now set 'tzone' to different values
#' tzone(x) <- "UTC"
#' str(x)
#'
#' tzone(x) <- "America/Chicago"
#' str(x)
#'
#' y <- timeBasedSeq('2010-01-01/2010-01-03 12:00/H')
#' y <- xts(seq_along(y), y, tzone = "America/New_York")
#'
#' # Changing the tzone does not change the internal index values, but it
#' # does change how the index is printed!
#' head(y)
#' head(.index(y))
#' tzone(y) <- "Europe/London"
#' head(y) # the index prints with hours, but
#' head(.index(y)) # the internal index is not changed!
#'
tzone <- function(x, ...) {
UseMethod("tzone")
}
#' @rdname tzone
`indexTZ<-` <- function(x, value) {
.Deprecated("tzone<-", "xts")
`tzone<-`(x, value)
}
#' @rdname tzone
`tzone<-` <- function(x, value) {
UseMethod("tzone<-")
}
`tzone<-.xts` <-
function(x, value)
{
if (is.null(value)) {
value <- ""
}
tzone <- as.character(value)
attr(attr(x, "index"), "tzone") <- tzone
# Remove tz attrs (object created before 0.10-3)
attr(x, ".indexTZ") <- NULL
attr(x, "tzone") <- NULL
x
}
tzone.default <-
function(x, ...)
{
attr(x, "tzone")
}
`tzone<-.default` <-
function(x, value)
{
if (!is.null(value)) {
value <- as.character(value)
}
attr(x, "tzone") <- value
x
}
tzone.xts <-
function(x, ...)
{
tzone <- attr(attr(x, "index"), "tzone")
# For xts objects created pre-0.10.3
if (is.null(tzone)) {
# no tzone on the index
sq_tzone <- sQuote("tzone")
sq_both <- paste(sq_tzone, "or", sQuote(".indexTZ"))
warn_msg <-
paste0("index does not have a ", sq_tzone, " attribute")
tzone <- attr(x, "tzone")
if (is.null(tzone)) {
# no tzone on the xts object, look for .indexTZ
tzone <- attr(x, ".indexTZ")
}
if (is.null(tzone)) {
# no .indexTZ on the xts object
tzone <- ""
warn_msg <- paste0(warn_msg, "\n and xts object does not have a ",
sq_both, " attribute\n", " returning ", dQuote(tzone))
warning(warn_msg)
return(tzone)
}
sym <- deparse(substitute(x))
warning(warn_msg, "\n use ", sym,
" <- xts:::.update_index_attributes(", sym, ") to update the object")
}
return(tzone)
}
isClassWithoutTZ <-
function(tclass, object = NULL)
{
.classesWithoutTZ <- c("chron","dates","times","Date","yearmon","yearqtr")
has_no_tz <- FALSE
if (is.null(object)) {
has_no_tz <- any(tclass %in% .classesWithoutTZ)
} else {
has_no_tz <- inherits(object, .classesWithoutTZ)
}
return(has_no_tz)
}
isUTC <- function(tz = NULL) {
if (is.null(tz)) {
tz <- Sys.timezone()
}
switch(tz,
"UTC" = ,
"GMT" = ,
"Etc/UTC" = ,
"Etc/GMT" = ,
"GMT-0" = ,
"GMT+0" = ,
"GMT0" = TRUE,
FALSE)
}
check.TZ <- function(x, ...)
{
check <- getOption("xts_check_TZ")
if (!is.null(check) && !check) {
return()
}
x_tz <- tzone(x)
x_tclass <- tclass(x)
if (isClassWithoutTZ(x_tclass)) {
# warn if tzone is not UTC or GMT (GMT is not technically correct, since
# it *is* a timezone, but it should work for all practical purposes)
if (!isUTC(x_tz)) {
warning(paste0("object index class (", paste(x_tclass, collapse = ", "),
") does not support timezones.\nExpected 'UTC' timezone, but tzone is ",
sQuote(x_tz)), call. = FALSE)
} else {
return()
}
}
x_tz_str <- as.character(x_tz)
sys_tz <- Sys.getenv("TZ")
if (!is.null(x_tz) && x_tz_str != "" && !identical(sys_tz, x_tz_str)) {
msg <- paste0("object timezone ('", x_tz, "') is different ",
"from system timezone ('", sys_tz, "')")
if (is.null(check)) {
# xts_check_TZ is NULL by default
# set to TRUE after messaging user how to disable the warning
msg <- paste0(msg, "\n NOTE: set 'options(xts_check_TZ = FALSE)' ",
"to disable this warning\n",
" This note is displayed once per session")
options(xts_check_TZ = TRUE)
}
warning(msg, call. = FALSE)
}
}
xts/R/OHLC.R 0000644 0001762 0000144 00000007247 14654242576 012172 0 ustar ligges users #
# 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 2 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 .
# functions from quantmod to check for OHLC style/columns
# NOT TO BE EXPORTED
#
`OHLCV` <-
function (x)
{
if (is.OHLCV(x))
return(x[, has.OHLCV(x, 1)])
NULL
}
`is.OHLCV` <-
function(x)
{
all(has.Op(x),has.Hi(x),has.Lo(x),has.Cl(x),has.Vo(x))
}
`has.OHLCV` <-
function(x,which=FALSE)
{
if(which) {
c(has.Op(x,1),has.Hi(x,1),has.Lo(x,1),has.Cl(x,1),has.Vo(x,1))
} else {
c(has.Op(x),has.Hi(x),has.Lo(x),has.Cl(x),has.Vo(x))
}
}
`OHLC` <-
function (x)
{
if (is.OHLC(x))
return(x[, has.OHLC(x, 1)])
NULL
}
`is.OHLC` <-
function(x)
{
all(has.Op(x),has.Hi(x),has.Lo(x),has.Cl(x))
}
`has.OHLC` <-
function(x,which=FALSE)
{
if(which) {
c(has.Op(x,1),has.Hi(x,1),has.Lo(x,1),has.Cl(x,1))
} else {
c(has.Op(x),has.Hi(x),has.Lo(x),has.Cl(x))
}
}
`HLC` <-
function (x)
{
if (is.HLC(x))
return(x[, has.HLC(x, 1)])
NULL
}
`is.HLC` <-
function(x)
{
all(has.Hi(x),has.Lo(x),has.Cl(x))
}
`has.HLC` <-
function(x,which=FALSE)
{
if(which) {
c(has.Hi(x,1),has.Lo(x,1),has.Cl(x,1))
} else {
c(has.Hi(x),has.Lo(x),has.Cl(x))
}
}
`Op` <-
function(x)
{
if(has.Op(x))
return(x[,grep('Open',colnames(x),ignore.case=TRUE)])
NULL
}
`has.Op` <-
function(x,which=FALSE)
{
loc <- grep('Open',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0)))
return(ifelse(which,loc,TRUE))
ifelse(which,loc,FALSE)
}
`Hi` <-
function(x)
{
if(has.Hi(x))
return(x[,grep('High',colnames(x),ignore.case=TRUE)])
NULL
}
`has.Hi` <-
function(x,which=FALSE)
{
loc <- grep('High',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0)))
return(ifelse(which,loc,TRUE))
ifelse(which,loc,FALSE)
}
`Lo` <-
function(x)
{
if(has.Lo(x))
return(x[,grep('Low',colnames(x),ignore.case=TRUE)])
NULL
}
`has.Lo` <-
function(x,which=FALSE)
{
loc <- grep('Low',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0)))
return(ifelse(which,loc,TRUE))
ifelse(which,loc,FALSE)
}
`Cl` <-
function(x)
{
if(has.Cl(x))
return(x[,grep('Close',colnames(x),ignore.case=TRUE)])
NULL
}
`has.Cl` <-
function(x,which=FALSE)
{
loc <- grep('Close',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0)))
return(ifelse(which,loc,TRUE))
ifelse(which,loc,FALSE)
}
`Vo` <-
function(x)
{
#vo <- grep('Volume',colnames(x))
#if(!identical(vo,integer(0)))
if(has.Vo(x))
return(x[,grep('Volume',colnames(x),ignore.case=TRUE)])
NULL
}
`has.Vo` <-
function(x,which=FALSE)
{
loc <- grep('Volume',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0)))
return(ifelse(which,loc,TRUE))
ifelse(which,loc,FALSE)
}
`Ad` <-
function(x)
{
if(has.Ad(x))
return(x[,grep('Adjusted',colnames(x),ignore.case=TRUE)])
NULL
}
`has.Ad` <-
function(x,which=FALSE)
{
loc <- grep('Adjusted',colnames(x),ignore.case=TRUE)
if(!identical(loc,integer(0)))
return(ifelse(which,loc,TRUE))
ifelse(which,loc,FALSE)
}
xts/R/plot.R 0000644 0001762 0000144 00000172105 14702260001 012370 0 ustar ligges users #
# xts: eXtensible time-series
#
# Copyright (C) 2009-2015 Jeffrey A. Ryan jeff.a.ryan @ gmail.com
#
# Contributions from Ross Bennett and 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 2 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 .
current.xts_chob <- function() invisible(get(".xts_chob",.plotxtsEnv))
# Current design
#
# There is a main plot object that contains the plot title (and optional
# timespan), the x-axis labels and tick marks, and a list of 'panel' objects.
# The main plot object contains the objects/functions below.
#
# * Env: an environment holds all the plot information.
# * add_main_header(): add the main plot header
# * add_main_xaxis(): add the x-axis labels and ticks to the main plot.
# * new_panel(): create a new panel and add it to the plot.
# * get_xcoords(): get the x-coordinate values for the plot.
# * get_panel(): get a specific panel.
# * get_last_action_panel(): get the panel that had the last rendered action.
# * new_environment: create a new environment with 'Env' as its parent.
# Functions that aren't intended to be called externally:
#
# * update_panels(): re-calculate the x-axis and y-axis values.
# * render_panels(): render all the plot panels.
# * x_grid_lines(): plot the x-axis grid lines.
# * create_ylim(): create y-axis max/min, handling when max(x) == min(x).
# The panel object is composed of the following fields:
#
# * id: the numeric index of the panel in the plot's list of panels.
# * asp: the x/y aspect ratio for the panel (relative vertical size).
# * ylim: the ylim of the panel when it was created.
# * ylim_render: the ylim of the panel to use when rendering.
# * use_fixed_ylim: do not update the panel ylim based on all panels data
# * header: the panel title.
# * actions: a list of expressions used to render the panel.
# * add_action(): a function to add an action to the list.
#
# The panel has the 'yaxis_expr' expression for rendering the y-axis min/max
# values, labels, and grid lines/ticks. It also contains the x-axis grid
# expression because we need the y-axis min/max values to know where to draw
# the x-axis grid lines on the panel.
# Other notes
#
# Environments created by new_environment() (e.g. the 'lenv') are children of
# Env, so expressions evaluated in 'lenv' will look in Env for anything not
# found in 'lenv'.
#
# Visual representation of plot structure
#
# ____________________________________________________________________________
# / \
# | plot object / window |
# | |
# | ______________________________________________________________________ |
# | / \ |
# | | panel #1 | |
# | | __________________________________________________________________ | |
# | | / \ | |
# | | | header frame | | |
# | | \__________________________________________________________________/ | |
# | | __________________________________________________________________ | |
# | | / \ | |
# | | | series frame | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | \__________________________________________________________________/ | |
# | \______________________________________________________________________/ |
# | |
# | ______________________________________________________________________ |
# | / \ |
# | | panel #2 | |
# | | __________________________________________________________________ | |
# | | / \ | |
# | | | header frame | | |
# | | \__________________________________________________________________/ | |
# | | __________________________________________________________________ | |
# | | / \ | |
# | | | series frame | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | | | | |
# | | \__________________________________________________________________/ | |
# | \______________________________________________________________________/ |
# | |
# \____________________________________________________________________________/
#
# Currently not necessary, but potentially very useful:
# http://www.fromthebottomoftheheap.net/2011/07/23/passing-non-graphical-parameters-to-graphical-functions-using/
chart.lines <- function(x,
type="l",
lty=1,
lwd=2,
lend=1,
col=NULL,
up.col=NULL,
dn.col=NULL,
legend.loc=NULL,
log=FALSE,
...){
xx <- current.xts_chob()
switch(type,
h={
# use up.col and dn.col if specified
if (!is.null(up.col) && !is.null(dn.col)){
colors <- ifelse(x[,1] < 0, dn.col, up.col)
} else {
colors <- if (is.null(col)) 1 else col
}
if (length(colors) < nrow(x[,1]))
colors <- colors[1]
# x-coordinates for this column
xcoords <- xx$get_xcoords(x[,1])
lines(xcoords,x[,1],lwd=2,col=colors,lend=lend,lty=1,type="h",...)
},
p=, l=, b=, c=, o=, s=, S=, n={
if(is.null(col))
col <- xx$Env$theme$col
# ensure pars have ncol(x) elements
lty <- rep(lty, length.out = NCOL(x))
lwd <- rep(lwd, length.out = NCOL(x))
col <- rep(col, length.out = NCOL(x))
for(i in NCOL(x):1) {
# x-coordinates for this column
xcoords <- xx$get_xcoords(x[,i])
xi <- x[,i]
if (isTRUE(log)) xi <- log(xi)
lines(xcoords, xi, type=type, lend=lend, col=col[i],
lty=lty[i], lwd=lwd[i], ...)
}
},
{
# default case
warning(paste(type, "not recognized. Type must be one of
'p', 'l', 'b, 'c', 'o', 'h', 's', 'S', 'n'.
plot.xts supports the same types as plot.default,
see ?plot for valid arguments for type"))
}
)
if(!is.null(legend.loc)){
lc <- legend.coords(legend.loc, xx$Env$xlim, range(x, na.rm=TRUE))
legend(x=lc$x, y=lc$y, legend=colnames(x), xjust=lc$xjust, yjust=lc$yjust,
fill=col[1:NCOL(x)], bty="n")
}
}
add.par.from.dots <- function(call., ...) {
stopifnot(is.call(call.))
# from graphics:::.Pars
parnames <- c("xlog","ylog","adj","ann","ask","bg","bty","cex","cex.axis",
"cex.lab","cex.main","cex.sub","cin","col","col.axis","col.lab",
"col.main","col.sub","cra","crt","csi","cxy","din","err",
"family", "fg","fig","fin","font","font.axis","font.lab",
"font.main","font.sub","lab","las","lend","lheight","ljoin",
"lmitre","lty","lwd","mai","mar","mex","mfcol","mfg","mfrow",
"mgp","mkh","new","oma","omd","omi","page","pch","pin","plt",
"ps","pty","smo","srt","tck","tcl","usr","xaxp","xaxs","xaxt",
"xpd","yaxp","yaxs","yaxt","ylbias")
dots <- list(...)
argnames <- names(dots)
pm <- match(argnames, parnames, nomatch = 0L)
call.list <- as.list(call.)
# only pass the args from dots ('...') that are in parnames
as.call(c(call.list, dots[pm > 0L]))
}
isNullOrFalse <- function(x) {
is.null(x) || identical(x, FALSE)
}
# Main plot.xts method.
# author: Ross Bennett (adapted from Jeffrey Ryan's chart_Series)
#' Plotting xts Objects
#'
#' Plotting for xts objects.
#'
#' Possible values for arguments `major.ticks`, `minor.ticks`, and
#' `grid.ticks.on` include \sQuote{auto}, \sQuote{minute}, \sQuote{hours},
#' \sQuote{days}, \sQuote{weeks}, \sQuote{months}, \sQuote{quarters}, and
#' \sQuote{years}. The default is \sQuote{auto}, which attempts to determine
#' sensible locations from the periodicity and locations of observations. The
#' other values are based on the possible values for the `ticks.on`
#' argument of [`axTicksByTime()`].
#'
#' @param x A xts object.
#' @param y Not used, always `NULL`.
#' @param \dots Any passthrough arguments for `lines()` and `points()`.
#' @param subset An ISO8601-style subset string.
#' @param panels Character vector of expressions to plot as panels.
#' @param multi.panel Either `TRUE`, `FALSE`, or an integer less than or equal
#' to the number of columns in the data set. When `TRUE`, each column of the
#' data is plotted in a separate panel. When an integer 'n', the data will be
#' plotted in groups of 'n' columns per panel and each group will be plotted
#' in a separate panel.
#' @param col Color palette to use.
#' @param up.col Color for positive bars when `type = "h"`.
#' @param dn.col Color for negative bars when `type = "h"`.
#' @param bg Background color of plotting area, same as in [`par()`].
#' @param type The type of plot to be drawn, same as in [`plot()`].
#' @param lty Set the line type, same as in [`par()`].
#' @param lwd Set the line width, same as in [`par()`].
#' @param lend Set the line end style, same as in [`par()`].
#' @param main Main plot title.
#' @param main.timespan Should the timespan of the series be shown in the top
#' right corner of the plot?
#' @param observation.based When `TRUE`, all the observations are equally spaced
#' along the x-axis. When `FALSE` (the default) the observations on the x-axis
#' are spaced based on the time index of the data.
#' @param log Should the y-axis be in log scale? Default `FALSE`.
#' @param ylim The range of the y axis.
#' @param yaxis.same Should 'ylim' be the same for every panel? Default `TRUE`.
#' @param yaxis.left Add y-axis labels to the left side of the plot?
#' @param yaxis.right Add y-axis labels to the right side of the plot?
#' @param yaxis.ticks Desired number of y-axis grid lines. The actual number of
#' grid lines is determined by the `n` argument to [`pretty()`].
#' @param major.ticks Period specifying locations for major tick marks and labels
#' on the x-axis. See Details for possible values.
#' @param minor.ticks Period specifying locations for minor tick marks on the
#' x-axis. When `NULL`, minor ticks are not drawn. See details for possible
#' values.
#' @param grid.ticks.on Period specifying locations for vertical grid lines.
#' See details for possible values.
#' @param grid.ticks.lwd Line width of the grid.
#' @param grid.ticks.lty Line type of the grid.
#' @param grid.col Color of the grid.
#' @param labels.col Color of the axis labels.
#' @param format.labels Label format to draw lower frequency x-axis ticks and
#' labels passed to [`axTicksByTime()`]
#' @param grid2 Color for secondary x-axis grid.
#' @param legend.loc Places a legend into one of nine locations on the chart:
#' bottomright, bottom, bottomleft, left, topleft, top, topright, right, or
#' center. Default `NULL` does not draw a legend.
#' @param on Panel number to draw on. A new panel will be drawn if `on = NA`.
#' The default, `on = 0`, will add to the active panel. The active panel is
#' defined as the panel on which the most recent action was performed. Note
#' that only the first element of `on` is checked for the default behavior to
#' add to the last active panel.
#' @param extend.xaxis When `TRUE`, extend the x-axis before and/or after the
#' plot's existing time index range, so all of of the time index values of
#' the new series are included in the plot. Default `FALSE`.
#'
#' @author Ross Bennett
#'
#' @seealso [`addSeries()`], [`addPanel()`]
#'
#' @references based on [`chart_Series()`][quantmod::quantmod] in \pkg{quantmod}
#' written by Jeffrey A. Ryan
#'
#' @examples
#'
#' \dontrun{
#' data(sample_matrix)
#' sample.xts <- as.xts(sample_matrix)
#'
#' # plot the Close
#' plot(sample.xts[,"Close"])
#'
#' # plot a subset of the data
#' plot(sample.xts[,"Close"], subset = "2007-04-01/2007-06-31")
#'
#' # function to compute simple returns
#' simple.ret <- function(x, col.name){
#' x[,col.name] / lag(x[,col.name]) - 1
#' }
#'
#' # plot the close and add a panel with the simple returns
#' plot(sample.xts[,"Close"])
#' R <- simple.ret(sample.xts, "Close")
#' lines(R, type = "h", on = NA)
#'
#' # add the 50 period simple moving average to panel 1 of the plot
#' library(TTR)
#' lines(SMA(sample.xts[,"Close"], n = 50), on = 1, col = "blue")
#'
#' # add month end points to the chart
#' points(sample.xts[endpoints(sample.xts[,"Close"], on = "months"), "Close"],
#' col = "red", pch = 17, on = 1)
#'
#' # add legend to panel 1
#' addLegend("topright", on = 1,
#' legend.names = c("Close", "SMA(50)"),
#' lty = c(1, 1), lwd = c(2, 1),
#' col = c("black", "blue", "red"))
#' }
#'
plot.xts <- function(x,
y=NULL,
...,
subset="",
panels=NULL,
multi.panel=FALSE,
col=1:8,
up.col=NULL,
dn.col=NULL,
bg="#FFFFFF",
type="l",
lty=1,
lwd=2,
lend=1,
main=deparse(substitute(x)),
main.timespan=TRUE,
observation.based=FALSE,
log=FALSE,
ylim=NULL,
yaxis.same=TRUE,
yaxis.left=TRUE,
yaxis.right=TRUE,
yaxis.ticks=5,
major.ticks="auto",
minor.ticks=NULL,
grid.ticks.on="auto",
grid.ticks.lwd=1,
grid.ticks.lty=1,
grid.col="darkgray",
labels.col="#333333",
format.labels=TRUE,
grid2="#F5F5F5",
legend.loc=NULL,
extend.xaxis=FALSE){
# check for colorset or col argument
if(hasArg("colorset")) {
col <- eval.parent(plot.call$colorset)
}
# ensure pars have ncol(x) elements
col <- rep(col, length.out = NCOL(x))
lty <- rep(lty, length.out = NCOL(x))
lwd <- rep(lwd, length.out = NCOL(x))
# Small multiples with multiple pages behavior occurs when multi.panel is
# an integer. (i.e. multi.panel=2 means to iterate over the data in a step
# size of 2 and plot 2 panels on each page
# Make recursive calls and return
if(is.numeric(multi.panel)){
multi.panel <- min(NCOL(x), multi.panel)
idx <- seq.int(1L, NCOL(x), 1L)
chunks <- split(idx, ceiling(seq_along(idx)/multi.panel))
if(!is.null(panels) && nchar(panels) > 0){
# we will plot the panels, but not plot the data by column
multi.panel <- FALSE
} else {
# we will plot the data by column, but not the panels
multi.panel <- TRUE
panels <- NULL
# set the ylim based on the data passed into the x argument
if(yaxis.same)
ylim <- range(x[subset], na.rm=TRUE)
}
for(i in 1:length(chunks)){
tmp <- chunks[[i]]
p <- plot.xts(x=x[,tmp],
y=y,
...=...,
subset=subset,
panels=panels,
multi.panel=multi.panel,
col=col[tmp],
up.col=up.col,
dn.col=dn.col,
bg=bg,
type=type,
lty=lty[tmp],
lwd=lwd[tmp],
lend=lend,
main=main,
observation.based=observation.based,
log=log,
ylim=ylim,
yaxis.same=yaxis.same,
yaxis.left=yaxis.left,
yaxis.right=yaxis.right,
yaxis.ticks=yaxis.ticks,
major.ticks=major.ticks,
minor.ticks=minor.ticks,
grid.ticks.on=grid.ticks.on,
grid.ticks.lwd=grid.ticks.lwd,
grid.ticks.lty=grid.ticks.lty,
grid.col=grid.col,
labels.col=labels.col,
format.labels=format.labels,
grid2=grid2,
legend.loc=legend.loc,
extend.xaxis=extend.xaxis)
if(i < length(chunks))
print(p)
}
# NOTE: return here so we don't draw another chart
return(p)
}
cs <- new.replot_xts()
# major.ticks shouldn't be null so we'll set major.ticks here if it is null
if(is.null(major.ticks)) {
xs <- x[subset]
mt <- c(years=nyears(xs),
months=nmonths(xs),
days=ndays(xs))
major.ticks <- names(mt)[rev(which(mt < 30))[1]]
}
# add theme and charting parameters to Env
plot.call <- match.call(expand.dots=TRUE)
cs$Env$theme <-
list(up.col = up.col,
dn.col = dn.col,
col = col,
rylab = yaxis.right,
lylab = yaxis.left,
bg = bg,
grid = grid.col,
grid2 = grid2,
labels = labels.col,
# String rotation in degrees. See comment about 'crt'. Only supported by text()
srt = if (hasArg("srt")) eval.parent(plot.call$srt) else 0,
# Rotation of axis labels:
# 0: parallel to the axis (default),
# 1: horizontal,
# 2: perpendicular to the axis,
# 3: vertical
las = if (hasArg("las")) eval.parent(plot.call$las) else 0,
# magnification for axis annotation relative to current 'cex' value
cex.axis = if (hasArg("cex.axis")) eval.parent(plot.call$cex.axis) else 0.9)
# /theme
# multiplier to magnify plotting text and symbols
cs$Env$cex <- if (hasArg("cex")) eval.parent(plot.call$cex) else 0.6
# lines of margin to the 4 sides of the plot: c(bottom, left, top, right)
cs$Env$mar <- if (hasArg("mar")) eval.parent(plot.call$mar) else c(3,2,0,2)
cs$Env$format.labels <- format.labels
cs$Env$yaxis.ticks <- yaxis.ticks
cs$Env$major.ticks <- if (isTRUE(major.ticks)) "auto" else major.ticks
cs$Env$minor.ticks <- if (isTRUE(minor.ticks)) "auto" else minor.ticks
cs$Env$grid.ticks.on <- if (isTRUE(grid.ticks.on)) "auto" else grid.ticks.on
cs$Env$grid.ticks.lwd <- grid.ticks.lwd
cs$Env$grid.ticks.lty <- grid.ticks.lty
cs$Env$type <- type
cs$Env$lty <- lty
cs$Env$lwd <- lwd
cs$Env$lend <- lend
cs$Env$legend.loc <- legend.loc
cs$Env$extend.xaxis <- extend.xaxis
cs$Env$observation.based <- observation.based
cs$Env$log <- isTRUE(log)
# Do some checks on x
if(is.character(x))
stop("'x' must be a time-series object")
# Raw returns data passed into function
cs$Env$xdata <- x
cs$Env$xsubset <- subset
cs$Env$column_names <- colnames(x)
cs$Env$nobs <- NROW(cs$Env$xdata)
cs$Env$main <- main
cs$Env$main.timespan <- main.timespan
cs$Env$ylab <- if (hasArg("ylab")) eval.parent(plot.call$ylab) else ""
xdata_ylim <- cs$create_ylim(cs$Env$xdata[subset,])
if(isTRUE(multi.panel)){
n_cols <- NCOL(cs$Env$xdata)
asp <- ifelse(n_cols > 1, n_cols, 3)
if (hasArg("yaxis.same") && hasArg("ylim") && !is.null(ylim)) {
warning("only 'ylim' or 'yaxis.same' should be provided; using 'ylim'")
}
for(i in seq_len(n_cols)) {
# create a local environment for each panel
lenv <- cs$new_environment()
lenv$xdata <- cs$Env$xdata[subset,i]
lenv$type <- cs$Env$type
if (is.null(ylim)) {
if (yaxis.same) {
lenv$ylim <- xdata_ylim # set panel ylim using all columns
lenv$use_fixed_ylim <- FALSE # update panel ylim when rendering
} else {
panel_ylim <- cs$create_ylim(lenv$xdata)
lenv$ylim <- panel_ylim # set panel ylim using this column
lenv$use_fixed_ylim <- TRUE # do NOT update panel ylim when rendering
}
} else {
lenv$ylim <- ylim # use the ylim argument value
lenv$use_fixed_ylim <- TRUE # do NOT update panel ylim when rendering
}
# allow color and line attributes for each panel in a multi.panel plot
lenv$lty <- cs$Env$lty[i]
lenv$lwd <- cs$Env$lwd[i]
lenv$col <- cs$Env$theme$col[i]
lenv$log <- isTRUE(log)
exp <- quote(chart.lines(xdata[xsubset],
type=type,
lty=lty,
lwd=lwd,
lend=lend,
col=col,
log=log,
up.col=theme$up.col,
dn.col=theme$dn.col,
legend.loc=legend.loc))
exp <- as.expression(add.par.from.dots(exp, ...))
# create the panels
this_panel <-
cs$new_panel(lenv$ylim,
asp = asp,
envir = lenv,
header = cs$Env$column_names[i],
draw_left_yaxis = yaxis.left,
draw_right_yaxis = yaxis.right,
use_fixed_ylim = lenv$use_fixed_ylim,
use_log_yaxis = log)
# plot data
this_panel$add_action(exp, env = lenv)
}
} else {
if(type == "h" && NCOL(x) > 1)
warning("only the univariate series will be plotted")
if (is.null(ylim)) {
yrange <- xdata_ylim # set ylim using all columns
use_fixed_ylim <- FALSE # update panel ylim when rendering
} else {
yrange <- ylim # use the ylim argument value
use_fixed_ylim <- TRUE # do NOT update panel ylim when rendering
}
# create the chart's main panel
main_panel <-
cs$new_panel(ylim = yrange,
asp = 3,
envir = cs$Env,
header = "",
use_fixed_ylim = use_fixed_ylim,
draw_left_yaxis = yaxis.left,
draw_right_yaxis = yaxis.right,
use_log_yaxis = log)
exp <- quote(chart.lines(xdata[xsubset],
type=type,
lty=lty,
lwd=lwd,
lend=lend,
col=theme$col,
log=log,
up.col=theme$up.col,
dn.col=theme$dn.col,
legend.loc=legend.loc))
exp <- as.expression(add.par.from.dots(exp, ...))
main_panel$add_action(exp)
assign(".xts_chob", cs, .plotxtsEnv)
}
# Plot the panels or default to a simple line chart
if(!is.null(panels) && nchar(panels) > 0) {
panels <- parse(text=panels, srcfile=NULL)
for( p in 1:length(panels)) {
if(length(panels[p][[1]][-1]) > 0) {
cs <- eval(panels[p])
} else {
cs <- eval(panels[p])
}
}
}
assign(".xts_chob", cs, .plotxtsEnv)
cs
}
# apply a function to the xdata in the xts chob and add a panel with the result
#' Add a panel to an existing xts plot
#'
#' Apply a function to the data of an existing xts plot object and plot the
#' result on an existing or new panel. `FUN` should have arguments `x` or `R`
#' for the data of the existing xts plot object to be passed to. All other
#' additional arguments for `FUN` are passed through \dots.
#'
#' @param FUN An xts object to plot.
#' @param main Main title for a new panel if drawn.
#' @param on Panel number to draw on. A new panel will be drawn if `on = NA`.
#' @param type The type of plot to be drawn, same as in [`plot()`].
#' @param col Color palette to use, set by default to rational choices.
#' @param lty Set the line type, same as in [`par()`].
#' @param lwd Set the line width, same as in [`par()`].
#' @param pch The type of plot to be drawn, same as in [`par()`].
#' @param \dots Additional named arguments passed through to `FUN` and any
#' other graphical passthrough parameters.
#'
#' @seealso [`plot.xts()`], [`addSeries()`]
#'
#' @author Ross Bennett
#'
#' @examples
#'
#' library(xts)
#' data(sample_matrix)
#' sample.xts <- as.xts(sample_matrix)
#'
#' calcReturns <- function(price, method = c("discrete", "log")){
#' px <- try.xts(price)
#' method <- match.arg(method)[1L]
#' returns <- switch(method,
#' simple = ,
#' discrete = px / lag(px) - 1,
#' compound = ,
#' log = diff(log(px)))
#' reclass(returns, px)
#' }
#'
#' # plot the Close
#' plot(sample.xts[,"Close"])
#' # calculate returns
#' addPanel(calcReturns, method = "discrete", type = "h")
#' # Add simple moving average to panel 1
#' addPanel(rollmean, k = 20, on = 1)
#' addPanel(rollmean, k = 40, col = "blue", on = 1)
#'
addPanel <- function(FUN, main="", on=NA, type="l", col=NULL, lty=1, lwd=1, pch=1, ...){
# get the chob and the raw data (i.e. xdata)
chob <- current.xts_chob()
# xdata will be passed as first argument to FUN
xdata <- chob$Env$xdata
fun <- match.fun(FUN)
.formals <- formals(fun)
if("..." %in% names(.formals)) {
# Just call do.call if FUN has '...'
x <- try(do.call(fun, c(list(xdata), list(...)), quote=TRUE), silent=TRUE)
} else {
# Otherwise, ensure we only pass relevant args to FUN
.formals <- modify.args(formals=.formals, arglist=list(...))
.formals[[1]] <- quote(xdata)
x <- try(do.call(fun, .formals), silent=TRUE)
}
if(inherits(x, "try-error")) {
message(paste("FUN function failed with message", x))
return(NULL)
}
addSeriesCall <- quote(addSeries(x = x, main = main, on = on,
type = type, col = col, lty = lty, lwd = lwd, pch = pch))
addSeriesCall <- add.par.from.dots(addSeriesCall, ...)
eval(addSeriesCall)
}
# Add a time series to an existing xts plot
# author: Ross Bennett
#' Add a time series to an existing xts plot
#'
#' Add a time series to an existing xts plot
#'
#' @param x An xts object to add to the plot.
#' @param main Main title for a new panel if drawn.
#' @param on Panel number to draw on. A new panel will be drawn if `on = NA`.
#' @param type The type of plot to be drawn, same as in [`plot()`].
#' @param col Color palette to use, set by default to rational choices.
#' @param lty Set the line type, same as in [`par()`].
#' @param lwd Set the line width, same as in [`par()`].
#' @param pch The type of plot to be drawn, same as in [`par()`].
#' @param \dots Any other passthrough graphical parameters.
#'
#' @author Ross Bennett
#'
addSeries <- function(x, main="", on=NA, type="l", col=NULL, lty=1, lwd=1, pch=1, ...){
plot_object <- current.xts_chob()
lenv <- plot_object$new_environment()
lenv$plot_lines <- function(x, ta, on, type, col, lty, lwd, pch, ...){
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
xDataSubset <- xdata[xsubset]
# we can add points that are not necessarily at the points
# on the main series, but need to ensure the new series only
# has index values within the xdata subset
if(xsubset == "") {
subset.range <- xsubset
} else {
fmt <- "%Y-%m-%d %H:%M:%OS6"
subset.range <- paste(format(start(xDataSubset), fmt),
format(end(xDataSubset), fmt), sep = "/")
}
xds <- .xts(, .index(xDataSubset), tzone=tzone(xdata))
ta.y <- merge(ta, xds)[subset.range]
if (!isTRUE(x$Env$extend.xaxis)) {
xi <- .index(ta.y)
xc <- .index(xds)
xsubset <- which(xi >= xc[1] & xi <= xc[length(xc)])
ta.y <- ta.y[xsubset]
}
chart.lines(ta.y, type=type, col=col, lty=lty, lwd=lwd, pch=pch, ...)
}
# get tag/value from dots
expargs <- substitute(alist(ta=x,
on=on,
type=type,
col=col,
lty=lty,
lwd=lwd,
pch=pch,
...))
# capture values from caller, so we don't need to copy objects to lenv,
# since this gives us evaluated versions of all the object values
expargs <- lapply(expargs[-1L], eval, parent.frame())
exp <- as.call(c(quote(plot_lines),
x = quote(current.xts_chob()),
expargs))
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
lenv$xdata <- merge(x,xdata,retside=c(TRUE,FALSE))
if(hasArg("ylim")) {
ylim <- eval.parent(substitute(alist(...))$ylim)
} else {
ylim <- range(lenv$xdata[xsubset], na.rm=TRUE)
if(all(ylim == 0)) ylim <- c(-1, 1)
}
lenv$ylim <- ylim
if(is.na(on[1])){
# add series to a new panel
use_log <- isTRUE(eval.parent(substitute(alist(...))$log))
this_panel <- plot_object$new_panel(lenv$ylim,
asp = 1,
envir = lenv,
header = main,
use_log_yaxis = use_log)
# plot data
this_panel$add_action(exp, env = lenv)
} else {
for(i in on) {
plot_object$add_panel_action(i, exp, lenv)
}
}
plot_object
}
# Add time series of lines to an existing xts plot
# author: Ross Bennett
#' @param pch the plotting character to use, same as in 'par'
#' @rdname plot.xts
lines.xts <- function(x, ..., main="", on=0, col=NULL, type="l", lty=1, lwd=1, pch=1){
if(!is.na(on[1]))
if(on[1] == 0) on[1] <- current.xts_chob()$get_last_action_panel()$id
addSeries(x, ...=..., main=main, on=on, type=type, col=col, lty=lty, lwd=lwd, pch=pch)
}
# Add time series of points to an existing xts plot
# author: Ross Bennett
#' @param pch the plotting character to use, same as in 'par'
#' @rdname plot.xts
points.xts <- function(x, ..., main="", on=0, col=NULL, pch=1){
if(!is.na(on[1]))
if(on[1] == 0) on[1] <- current.xts_chob()$get_last_action_panel()$id
addSeries(x, ...=..., main=main, on=on, type="p", col=col, pch=pch)
}
# Add vertical lines to an existing xts plot
# author: Ross Bennett
#' Add vertical lines to an existing xts plot
#'
#' Add vertical lines and labels to an existing xts plot.
#'
#' @param events An xts object of events and their associated labels. It is
#' ensured that the first column of `events` is the event description/label.
#' @param main Main title for a new panel, if drawn.
#' @param on Panel number to draw on. A new panel will be drawn if `on = NA`.
#' The default, `on = 0`, will add to the active panel. The active panel is
#' defined as the panel on which the most recent action was performed. Note
#' that only the first element of `on` is checked for the default behavior to
#' add to the last active panel.
#' @param lty Set the line type, same as in [`par()`].
#' @param lwd Set the line width, same as in [`par()`].
#' @param col Color palette to use, set by default to rational choices.
#' @param \dots Any other passthrough parameters to [`text()`] to control how
#' the event labels are drawn.
#'
#' @author Ross Bennett
#'
#' @examples
#'
#' \dontrun{
#' library(xts)
#' data(sample_matrix)
#' sample.xts <- as.xts(sample_matrix)
#' events <- xts(letters[1:3],
#' as.Date(c("2007-01-12", "2007-04-22", "2007-06-13")))
#' plot(sample.xts[,4])
#' addEventLines(events, srt = 90, pos = 2)
#' }
#'
addEventLines <- function(events, main="", on=0, lty=1, lwd=1, col=1, ...){
events <- try.xts(events)
plot_object <- current.xts_chob()
if(!is.na(on[1]))
if(on[1] == 0) on[1] <- plot_object$get_last_action_panel()$id
if(nrow(events) > 1){
if(length(lty) == 1) lty <- rep(lty, nrow(events))
if(length(lwd) == 1) lwd <- rep(lwd, nrow(events))
if(length(col) == 1) col <- rep(col, nrow(events))
}
lenv <- plot_object$new_environment()
lenv$plot_event_lines <- function(x, events, on, lty, lwd, col, ...){
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
panel <- x$get_active_panel()
if (panel$use_log_yaxis) {
ypos <- log(exp(panel$ylim_render[2]) * 0.995)
} else {
ypos <- panel$ylim_render[2] * 0.995
}
# we can add points that are not necessarily at the points on the main series
subset.range <-
paste(format(start(xdata[xsubset]), "%Y%m%d %H:%M:%OS6"),
format(end(xdata[xsubset]), "%Y%m%d %H:%M:%OS6"),
sep = "/")
ta.adj <- merge(n=.xts(1:NROW(xdata[xsubset]),
.index(xdata[xsubset]),
tzone=tzone(xdata)),
.xts(rep(1, NROW(events)),# use numeric for the merge
.index(events)))[subset.range]
# should we not merge and only add events that are in index(xdata)?
ta.y <- ta.adj[,-1]
# the merge should result in NAs for any object that is not in events
event.ind <- which(!is.na(ta.y))
abline(v=x$get_xcoords()[event.ind], col=col, lty=lty, lwd=lwd)
text(x=x$get_xcoords()[event.ind], y=ypos,
labels=as.character(events[,1]),
col=x$Env$theme$labels, ...)
}
# get tag/value from dots
expargs <- substitute(alist(events=events,
on=on,
lty=lty,
lwd=lwd,
col=col,
...))
# capture values from caller, so we don't need to copy objects to lenv,
# since this gives us evaluated versions of all the object values
expargs <- lapply(expargs[-1L], eval, parent.frame())
exp <- as.call(c(quote(plot_event_lines),
x = quote(current.xts_chob()),
expargs))
if(is.na(on[1])){
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
lenv$xdata <- xdata
ylim <- range(xdata[xsubset], na.rm=TRUE)
lenv$ylim <- ylim
# add series to a new panel
this_panel <- plot_object$new_panel(lenv$ylim,
asp = 1,
envir = lenv,
header = main)
# plot data
this_panel$add_action(exp, env = lenv)
} else {
for(i in on) {
plot_object$add_panel_action(i, exp, lenv)
}
}
plot_object
}
# Add legend to an existing xts plot
# author: Ross Bennett
#' Add Legend
#'
#' Add a legend to an existing panel.
#'
#' @param legend.loc One of nine locations: bottomright, bottom, bottomleft,
#' left, topleft, top, topright, right, or center.
#' @param legend.names Character vector of names for the legend. When `NULL`,
#' the column names of the current plot object are used.
#' @param col Fill colors for the legend. When `NULL`, the colorset of the
#' current plot object data is used.
#' @param ncol Number of columns for the legend.
#' @param on Panel number to draw on. A new panel will be drawn if `on = NA`.
#' The default, `on = 0`, will add to the active panel. The active panel is
#' defined as the panel on which the most recent action was performed. Note
#' that only the first element of `on` is checked for the default behavior to
#' add to the last active panel.
#' @param \dots Any other passthrough parameters to [`legend()`].
#'
#' @author Ross Bennett
#'
addLegend <- function(legend.loc="topright", legend.names=NULL, col=NULL, ncol=1, on=0, ...){
plot_object <- current.xts_chob()
if(!is.na(on[1]))
if(on[1] == 0) on[1] <- plot_object$get_last_action_panel()$id
lenv <- plot_object$new_environment()
lenv$plot_legend <- function(x, legend.loc, legend.names, col, ncol, on, bty, text.col, ...){
if(is.na(on[1])){
yrange <- c(0, 1)
} else {
panel <- x$get_active_panel()
yrange <- panel$ylim_render
}
# this just gets the data of the main plot
# TODO: get the data of panels[on]
if(is.null(ncol)){
ncol <- NCOL(x$Env$xdata)
}
if(is.null(col)){
col <- x$Env$theme$col[1:NCOL(x$Env$xdata)]
}
if(is.null(legend.names)){
legend.names <- x$Env$column_names
}
if(missing(bty)){
bty <- "n"
}
if(missing(text.col)){
text.col <- x$Env$theme$labels
}
lc <- legend.coords(legend.loc, x$Env$xlim, yrange)
legend(x=lc$x, y=lc$y, legend=legend.names, xjust=lc$xjust, yjust=lc$yjust,
ncol=ncol, col=col, bty=bty, text.col=text.col, ...)
}
# get tag/value from dots
expargs <- substitute(alist(legend.loc=legend.loc,
legend.names=legend.names,
col=col,
ncol=ncol,
on=on,
...))
# capture values from caller, so we don't need to copy objects to lenv,
# since this gives us evaluated versions of all the object values
expargs <- lapply(expargs[-1L], eval, parent.frame())
exp <- as.call(c(quote(plot_legend),
x = quote(current.xts_chob()),
expargs))
# if on[1] is NA, then add a new frame for the legend
if(is.na(on[1])){
# add legend to a new panel
this_panel <- plot_object$new_panel(ylim = c(0, 1),
asp = 0.8,
envir = lenv,
header = "")
# legend data
this_panel$add_action(exp, env = lenv)
} else {
for(i in on) {
plot_object$add_panel_action(i, exp, lenv)
}
}
plot_object
}
# Determine legend coordinates based on legend location,
# range of x values and range of y values
legend.coords <- function(legend.loc, xrange, yrange) {
switch(legend.loc,
topleft = list(xjust = 0, yjust = 1, x = xrange[1], y = yrange[2]),
left = list(xjust = 0, yjust = 0.5, x = xrange[1], y = sum(yrange) / 2),
bottomleft = list(xjust = 0, yjust = 0, x = xrange[1], y = yrange[1]),
top = list(xjust = 0.5, yjust = 1, x = (xrange[1] + xrange[2]) / 2, y = yrange[2]),
center = list(xjust = 0.5, yjust = 0.5, x = (xrange[1] + xrange[2]) / 2, y = sum(yrange) / 2),
bottom = list(xjust = 0.5, yjust = 0, x = (xrange[1] + xrange[2]) / 2, y = yrange[1]),
topright = list(xjust = 1, yjust = 1, x = xrange[2], y = yrange[2]),
right = list(xjust = 1, yjust = 0.5, x = xrange[2], y = sum(yrange) / 2),
bottomright = list(xjust = 1, yjust = 0, x = xrange[2], y = yrange[1])
)
}
# Add a polygon to an existing xts plot
# author: Ross Bennett
#' Add a polygon to an existing xts plot
#'
#' Draw a polygon on an existing xts plot by specifying a time series of y
#' coordinates. The xts index is used for the x coordinates and the first two
#' columns are the upper and lower y coordinates, respectively.
#'
#' @param x An xts object to plot. Must contain 2 columns for the upper and
#' the lower y coordinates for the polygon. The first column is interpreted
#' as upper y coordinates and the second column as the lower y coordinates.
#' @param y `NULL`, not used.
#' @param main Main title for a new panel, if drawn.
#' @param on Panel number to draw on. A new panel will be drawn if `on = NA`.
#' @param col Color palette to use, set by default to rational choices.
#' @param \dots Any other passthrough parameters to [`par()`].
#'
#' @author Ross Bennett
#'
#' @references Based on code by Dirk Eddelbuettel from
#'
#'
#' @examples
#'
#' \dontrun{
#' library(xts)
#' data(sample_matrix)
#' x <- as.xts(sample_matrix)[,1]
#' ix <- index(x["2007-02"])
#' shade <- xts(matrix(rep(range(x), each = length(ix)), ncol = 2), ix)
#'
#' plot(x)
#'
#' # set on = -1 to draw the shaded region *behind* the main series
#' addPolygon(shade, on = -1, col = "lightgrey")
#' }
#'
addPolygon <- function(x, y=NULL, main="", on=NA, col=NULL, ...){
# add polygon to xts plot based on http://dirk.eddelbuettel.com/blog/2011/01/16/
# some simple checks
x <- try.xts(x)
if(!is.null(y)) stop("y is not null")
if(ncol(x) > 2) warning("more than 2 columns detected in x, only the first 2 will be used")
plot_object <- current.xts_chob()
lenv <- plot_object$new_environment()
lenv$plot_lines <- function(x, ta, on, col, ...){
xdata <- x$Env$xdata
xsubset <- x$Env$xsubset
xDataSubset <- xdata[xsubset]
if(is.null(col)) col <- x$Env$theme$col
# we can add points that are not necessarily at the points
# on the main series, but need to ensure the new series only
# has index values within the xdata subset
if(xsubset == "") {
subset.range <- xsubset
} else {
fmt <- "%Y-%m-%d %H:%M:%OS6"
subset.range <- paste(format(start(xDataSubset), fmt),
format(end(xDataSubset), fmt), sep = "/")
}
xds <- .xts(, .index(xDataSubset), tzone=tzone(xdata))
ta.y <- merge(ta, xds)[subset.range]
# NAs in the coordinates break the polygon which is not the behavior we want
ta.y <- na.omit(ta.y)
# x coordinates
n <- seq_len(NROW(ta.y))
xx <- x$get_xcoords(ta.y)[c(1, n, rev(n))]
# y coordinates upper and lower
# assume first column is upper and second column is lower y coords for
# initial prototype
yu <- as.vector(coredata(ta.y[,1]))
yl <- as.vector(coredata(ta.y[,2]))
polygon(x=xx, y=c(yl[1], yu, rev(yl)), border=NA, col=col, ...)
}
# get tag/value from dots
expargs <- substitute(alist(ta=x,
col=col,
on=on,
...))
# capture values from caller, so we don't need to copy objects to lenv,
# since this gives us evaluated versions of all the object values
expargs <- lapply(expargs[-1L], eval, parent.frame())
exp <- as.call(c(quote(plot_lines),
x = quote(current.xts_chob()),
expargs))
xdata <- plot_object$Env$xdata
xsubset <- plot_object$Env$xsubset
lenv$xdata <- merge(x,xdata,retside=c(TRUE,FALSE))
if(hasArg("ylim")) {
ylim <- eval.parent(substitute(alist(...))$ylim)
} else {
ylim <- range(lenv$xdata[xsubset], na.rm=TRUE)
if(all(ylim == 0)) ylim <- c(-1, 1)
}
lenv$ylim <- ylim
if(is.na(on[1])){
# add series to a new panel
this_panel <- plot_object$new_panel(ylim = lenv$ylim,
asp = 1,
envir = lenv,
header = main)
# plot data
this_panel$add_action(exp, env = lenv)
} else {
for(i in on) {
plot_object$add_panel_action(i, exp, lenv)
}
}
plot_object
}# polygon
# Based on quantmod/R/replot.R
new.replot_xts <- function(panel=1,asp=1,xlim=c(1,10),ylim=list(structure(c(1,10),fixed=FALSE))) {
# global variables
# 'Env' is mainly the environment for the plot window, but some elements are for panels/frames
Env <- new.env()
Env$active_panel_i <- panel
Env$asp <- 1
Env$xlim <- xlim # vector: c(min, max) (same for every panel)
Env$last_action_panel_id <- 1
# getters
get_ylim <- function() { update_panels(); get_active_panel()[["ylim_render"]] }
get_xlim <- function() { update_panels(); Env$xlim }
get_active_panel <- function() { get_panel(Env$active_panel_i) }
get_last_action_panel <- function() { get_panel(Env$last_action_panel_id) }
get_panel <- function(n)
{
if (n == 0) {
get_last_action_panel()
} else if (n > 0) {
Env$panels[[n]]
} else {
stop("'n' must be a positive integer")
}
}
add_panel_action <-
function(id,
expr,
env,
clip = TRUE,
where = c("last", "first", "background"),
...)
{
if (id < 0) {
where <- "first"
} else {
where <- match.arg(where)
}
this_panel <- get_panel(abs(id))
this_panel$add_action(expr, env, clip, where, ...)
}
create_ylim <-
function(x, const_y_mult = 0.2)
{
# Create y-axis limits from 'x'. Jitter the max/min limits by
# 'const_y_mult' if the max/min values are the same.
lim <- range(x, na.rm = TRUE)
if(isTRUE(all.equal(lim[1L], lim[2L]))) {
# if max and min are the same
if(lim[1L] == 0) {
lim <- c(-1, 1)
} else {
adj <- sign(lim[1L]) * const_y_mult
lim <- lim[1L] * c(1 - adj, 1 + adj)
}
}
return(lim)
}
# loop over panels and then actions
render_panels <-
function()
{
update_panels()
# all panel header/series asp pairs
all_asp <- lapply(Env$panels, function(p) p[["asp"]])
all_asp <- do.call(c, all_asp)
# panel header asp is always 5% of the total asp
panel_header_asp <- 0.05 * sum(all_asp)
# update panel header asp values
header_loc <- seq(1, length(all_asp), by = 2)
all_asp[header_loc] <- panel_header_asp
# main header asp is always 4% of the grand total asp
main_title_asp <- 0.04 * sum(all_asp)
all_asp <- c(main_title_asp, all_asp)
n_asp <- length(all_asp)
# render main plot header and x-axis
plot.window(Env$xlim, c(0, 1))
clip(par("usr")[1], par("usr")[2], 0, 1)
eval(Env$main_header_expr, Env) # header
eval(Env$main_xaxis_expr, Env) # x-axis
# render each panel
for (panel_n in seq_along(Env$panels)) {
panel <- Env$panels[[panel_n]]
# set the current active panel for the entire plot
Env$active_panel_i <- panel_n
is_header <- TRUE # header is always the first action
for (action in panel$actions) {
if (is_header) {
is_header <- FALSE
asp <- panel_header_asp
asp_n <- 2 * panel_n
ylim <- c(0, 1)
} else {
asp <- panel$asp["series"]
asp_n <- 2 * panel_n + 1
ylim <- panel$ylim_render
}
# scaled ylim
ylim_scale <- all_asp / asp * abs(diff(ylim))
ymin_adj <- sum(ylim_scale[-seq_len(asp_n)])
ymax_adj <- sum(ylim_scale[-(asp_n:n_asp)])
scaled_ylim <- c(ylim[1] - ymin_adj, ylim[2] + ymax_adj)
plot.window(Env$xlim, scaled_ylim)
if (attr(action, "clip")) {
clip(par("usr")[1], par("usr")[2], ylim[1], ylim[2])
}
action_env <- attr(action, "env")
eval(action, action_env)
}
}
}
get_xcoords <- function(xts_object = NULL, at_posix = FALSE) {
# unique index for all series (always POSIXct)
xcoords <- Env$xycoords$x
if (!is.null(xts_object)) {
# get the x-coordinates for the observations in xts_object
temp_xts <- .xts(seq_along(xcoords), xcoords, tzone = tzone(xts_object))
xcoords <- merge(temp_xts, xts_object,
fill = na.locf, # for duplicate index values
join = "right", retside = c(TRUE, FALSE))
if (!isTRUE(Env$extend.xaxis)) {
xc <- Env$xycoords$x
xi <- .index(xcoords)
xsubset <- which(xi >= xc[1] & xi <= xc[length(xc)])
xcoords <- xcoords[xsubset]
}
if(Env$observation.based && !at_posix) {
result <- drop(coredata(xcoords))
} else {
result <- .index(xcoords)
}
} else {
if(Env$observation.based && !at_posix) {
result <- seq_along(xcoords)
} else {
result <- xcoords
}
}
return(result)
}
# main plot header
Env$main_header_expr <- expression({
local({
text(x = xlim[1],
y = 1.0,
labels = main,
adj = c(0, 1),
cex = 1.1,
col = theme$labels,
font = 2)
if (main.timespan) {
text(x = xlim[2],
y = 1.0,
labels = paste(start(xdata[xsubset]),
end(xdata[xsubset]), sep = " / "),
adj = c(1, 1),
cex = 1,
col = theme$labels,
font = NULL)
}
}, new.env(TRUE, Env))
})
# main plot x-axis
Env$main_xaxis_expr <- expression({
local({
# add observation level ticks on x-axis if < 400 obs.
if (NROW(xdata[xsubset]) < 400) {
axis(1,
at = get_xcoords(),
labels = FALSE,
las = theme$las,
lwd.ticks = NULL,
mgp = NULL,
tcl = 0.3,
cex.axis = theme$cex.axis,
col = theme$labels,
col.axis = theme$grid2)
}
# and major and/or minor x-axis ticks and labels
xcoords <- get_xcoords()
x_index <- get_xcoords(at_posix = TRUE)
x_data <- .xts(, x_index, tzone = tzone(xdata))[xsubset]
use_major <- !isNullOrFalse(major.ticks)
use_minor <- !isNullOrFalse(minor.ticks)
types <- c("major", "minor")[c(use_major, use_minor)]
for (type in types) {
if (type== "major") {
axt <- axTicksByTime(x_data,
ticks.on = major.ticks,
format.labels = format.labels)
labels <- names(axt)
lwd.ticks <- 1.5
} else {
axt <- axTicksByTime(x_data,
ticks.on = minor.ticks,
format.labels = format.labels)
labels <- FALSE
lwd.ticks <- 0.75
}
axis(1,
at = xcoords[axt],
labels = labels,
las = theme$las,
lwd.ticks = lwd.ticks,
mgp = c(3,1.5,0),
tcl = -0.4,
cex.axis = theme$cex.axis,
col = theme$labels,
col.axis = theme$labels)
}
}, new.env(TRUE, Env))
})
# panel functionality
Env$panels <- list()
new_panel <-
function(ylim,
asp,
envir,
header,
...,
use_fixed_ylim = FALSE,
draw_left_yaxis = NULL,
draw_right_yaxis = NULL,
use_log_yaxis = FALSE,
title_timespan = FALSE)
{
panel <- new.env(TRUE, envir)
panel$id <- length(Env$panels) + 1
panel$asp <- c(header = 0.25, series = asp)
panel$ylim <- ylim
panel$ylim_render <- ylim
panel$use_fixed_ylim <- isTRUE(use_fixed_ylim)
panel$draw_left_yaxis <- ifelse(is.null(draw_left_yaxis), Env$theme$lylab, draw_left_yaxis)
panel$draw_right_yaxis <- ifelse(is.null(draw_right_yaxis), Env$theme$rylab, draw_right_yaxis)
panel$use_log_yaxis <- isTRUE(use_log_yaxis)
panel$header <- header
### actions
panel$actions <- list()
panel$add_action <-
function(expr,
env = Env,
clip = TRUE,
where = c("last", "first", "background"),
...)
{
if (!is.expression(expr)) {
expr <- as.expression(expr)
}
action <- structure(expr, clip = clip, env = env, ...)
panel$actions <-
switch(match.arg(where),
last = {
# after all the existing actions
append(panel$actions, list(action))
},
first = {
# after the header and grid lines
append(panel$actions, list(action), after = 3)
},
background = {
# after the header (which must be the 1st panel action)
append(panel$actions, list(action), after = 1)
})
Env$last_action_panel_id <<- panel$id
}
### header
# NOTE: this must be the 1st action for a panel
header_expr <-
expression({
text(x = xlim[1],
y = 0.3,
labels = header,
adj = c(0, 0),
pos = 4,
offset = 0,
cex = 0.9,
col = theme$labels,
font = NULL)
})
panel$add_action(header_expr, env = panel)
### y-axis
yaxis_expr <- expression({
if (use_fixed_ylim) {
# use the ylim argument
yl <- ylim
} else {
# use the updated ylim based on all panel data
yl <- ylim_render
}
# y-axis grid line labels and locations
if (use_log_yaxis) {
ylim_series <- exp(ylim_render)
# labels are based on the raw series values
grid_lbl <- pretty(ylim_series, Env$yaxis.ticks)
grid_lbl <- grid_lbl[grid_lbl >= ylim_series[1] & grid_lbl <= ylim_series[2]]
# locations are based on the log series values
grid_loc <- log(grid_lbl)
} else {
grid_loc <- pretty(yl, Env$yaxis.ticks)
grid_loc <- grid_loc[grid_loc >= yl[1] & grid_loc <= yl[2]]
grid_lbl <- grid_loc
}
# draw y-axis grid lines
segments(x0 = xlim[1], y0 = grid_loc,
x1 = xlim[2], y1 = grid_loc,
col = theme$grid,
lwd = grid.ticks.lwd,
lty = grid.ticks.lty)
# draw left y-axis grid labels
if (draw_left_yaxis) {
text(x = xlim[1],
y = grid_loc,
labels = format(grid_lbl, justify = "right"),
col = theme$labels,
srt = theme$srt,
offset = 0.5,
pos = 2,
cex = theme$cex.axis,
xpd = TRUE)
}
# draw right y-axis grid labels
if (draw_right_yaxis) {
text(x = xlim[2],
y = grid_loc,
labels = format(grid_lbl, justify = "right"),
col = theme$labels,
srt = theme$srt,
offset = 0.5,
pos = 4,
cex = theme$cex.axis,
xpd = TRUE)
}
# draw y-axis label
title(ylab = ylab[1], mgp = c(1, 1, 0))
})
panel$add_action(yaxis_expr, env = panel)
# x-axis grid
xaxis_action <- expression(x_grid_lines(xdata, grid.ticks.on, par("usr")[3:4]))
panel$add_action(xaxis_action, env = panel)
# append the new panel to the panel list
Env$panels <- append(Env$panels, list(panel))
return(panel)
}
update_panels <- function(headers=TRUE) {
# Recalculate each panel's 'ylim_render' value based on the
# 'xdata' of every action in the panel
for (panel_n in seq_along(Env$panels)) {
panel <- get_panel(panel_n)
if (!panel$use_fixed_ylim) {
# set 'ylim_render' to +/-Inf when ylim is NOT fixed, so
# it will be updated to include all the panel's data
panel$ylim_render <- c(Inf, -Inf)
# calculate a new ylim based on all the panel's data
for (action in panel$actions) {
action_env <- attr(action, "env")
action_data <- action_env$xdata
if (!is.null(action_data)) {
# some actions (e.g. addLegend) do not have 'xdata'
dat.range <- create_ylim(action_data[Env$xsubset])
# calculate new ylim based on the combination of the panel's
# original ylim and the action's 'xdata' ylim
new_ylim <-
c(min(panel$ylim[1], dat.range, na.rm = TRUE),
max(panel$ylim[2], dat.range, na.rm = TRUE))
# set to new ylim values
panel$ylim_render <- new_ylim
}
}
}
if (panel$use_log_yaxis) {
panel$ylim_render <- log(panel$ylim_render)
}
}
update_xaxis <- function(panel, x_axis)
{
# Create x-axis values using index values from data from all panels
for (action in panel$actions) {
action_env <- attr(action, "env")
action_data <- action_env$xdata
if (!is.null(action_data)) {
# some actions (e.g. addLegend) do not have 'xdata'
action_xaxis <- .index(action_data[Env$xsubset])
new_xaxis <- sort(unique(c(x_axis, action_xaxis)))
if (isTRUE(Env$extend.xaxis)) {
result <- new_xaxis
} else {
xaxis_rng <- range(x_axis, na.rm = TRUE)
result <- new_xaxis[new_xaxis >= xaxis_rng[1L] &
new_xaxis <= xaxis_rng[2L]]
}
}
}
return(result)
}
x_axis <- .index(Env$xdata[Env$xsubset])
for (panel in Env$panels) {
x_axis <- update_xaxis(panel, x_axis)
}
# Create x/y coordinates using the combined x-axis index
Env$xycoords <- xy.coords(x_axis, seq_along(x_axis))
if (Env$observation.based) {
Env$xlim <- c(1, length(get_xcoords()))
} else {
Env$xlim <- range(get_xcoords(), na.rm = TRUE)
}
}
# return
replot_env <- new.env()
class(replot_env) <- c("replot_xts","environment")
replot_env$Env <- Env
replot_env$new_panel <- new_panel
replot_env$get_xcoords <- get_xcoords
replot_env$update_panels <- update_panels
replot_env$render_panels <- render_panels
replot_env$get_panel <- get_panel
replot_env$add_panel_action <- add_panel_action
replot_env$get_xlim <- get_xlim
replot_env$get_ylim <- get_ylim
replot_env$create_ylim <- create_ylim
replot_env$get_active_panel <- get_active_panel
replot_env$get_last_action_panel <- get_last_action_panel
replot_env$new_environment <- function() { new.env(TRUE, Env) }
# function to plot the x-axis grid lines
replot_env$Env$x_grid_lines <- function(x, ticks.on, ylim)
{
if (isNullOrFalse(ticks.on)) {
invisible()
} else {
if (isTRUE(ticks.on)) ticks.on <- "auto"
xcoords <- get_xcoords()
x_index <- get_xcoords(at_posix = TRUE)
atbt <- axTicksByTime(.xts(, x_index, tzone = tzone(x)),
ticks.on = ticks.on)
segments(xcoords[atbt], ylim[1L],
xcoords[atbt], ylim[2L],
col = Env$theme$grid,
lwd = Env$grid.ticks.lwd,
lty = Env$grid.ticks.lty)
}
}
return(replot_env)
}
str.replot_xts <- function(object, ...) {
print(str(unclass(object)))
}
print.replot_xts <- function(x, ...) plot(x,...)
plot.replot_xts <- function(x, ...) {
# must set the background color before calling plot.new
obg <- par(bg = x$Env$theme$bg)
plot.new()
assign(".xts_chob",x,.plotxtsEnv)
# only reasonable way to fix X11/quartz issue
ocex <- par(cex = if(.Device == "X11") x$Env$cex else x$Env$cex * 1.5)
omar <- par(mar = x$Env$mar)
oxpd <- par(xpd = FALSE)
usr <- par("usr")
# reset par
on.exit(par(xpd = oxpd$xpd, cex = ocex$cex, mar = omar$mar, bg = obg$bg))
x$render_panels()
do.call("clip", as.list(usr)) # reset clipping region
invisible(x$Env$actions)
}
xts/R/isOrdered.R 0000644 0001762 0000144 00000004055 14654242576 013357 0 ustar ligges users #
# 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 2 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 .
#' Check If A Vector Is Ordered
#'
#' Check if a vector is strictly increasing, strictly decreasing, not
#' decreasing, or not increasing.
#'
#' Designed for internal use with \pkg{xts}, this provides highly optimized
#' tests for ordering.
#'
#' @param x A numeric vector.
#' @param increasing Test for increasing (`TRUE`) or decreasing (`FALSE`) values?
#' @param strictly When `TRUE`, vectors with duplicate values are *not*
#' considered ordered.
#'
#' @return A logical scalar indicating whether or not `x` is ordered.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`is.unsorted()`]
#'
#' @keywords misc
#' @examples
#'
#' # strictly increasing
#' isOrdered(1:10, increasing=TRUE)
#' isOrdered(1:10, increasing=FALSE)
#' isOrdered(c(1,1:10), increasing=TRUE)
#' isOrdered(c(1,1:10), increasing=TRUE, strictly=FALSE)
#'
#' # decreasing
#' isOrdered(10:1, increasing=TRUE)
#' isOrdered(10:1, increasing=FALSE)
#'
`isOrdered` <- function(x, increasing=TRUE, strictly=TRUE) {
# x must be of type double or integer. Checked in the C code.
if(is.character(x))
stop('character ordering unsupported')
if(!is.numeric(x))
x = as.numeric(x)
.Call(C_do_is_ordered,
x = x,
increasing = as.logical(increasing),
strictly = as.logical(strictly))
}
xts/R/all.equal.R 0000644 0001762 0000144 00000003073 14634167654 013315 0 ustar ligges users #
# xts: eXtensible time-series
#
# Copyright (C) 2019 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 2 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 .
all.equal.xts <-
function(target,
current,
...,
check.attributes = TRUE)
{
if (isTRUE(check.attributes)) {
# Remove potential index attributes on the objects
attrNames <- c(".indexCLASS", ".indexTZ", "tclass", "tzone")
for (aname in attrNames) {
attr(target, aname) <- NULL
attr(current, aname) <- NULL
}
# Order the object attributes
a <- attributes(target)
attributes(target) <- a[sort(names(a))]
a <- attributes(current)
attributes(current) <- a[sort(names(a))]
# Order the index attributes
a <- attributes(.index(target))
attributes(.index(target)) <- a[sort(names(a))]
a <- attributes(.index(current))
attributes(.index(current)) <- a[sort(names(a))]
}
NextMethod("all.equal")
}
xts/R/timeSeries.R 0000644 0001762 0000144 00000005612 14654242576 013550 0 ustar ligges users #
# 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 2 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 .
# functions to handle timeSeries <--> xts conversions
`re.timeSeries` <-
function(x,...) {
if(!requireNamespace('timeSeries', quietly=TRUE)) {
timeSeries <- function(...) message("package 'timeSeries' is required")
} else {
timeSeries <- timeSeries::timeSeries
}
# strip all non-'core' attributes so they're not attached to the Data slot
x.attr <- attributes(x)
xx <- structure(x,dimnames=x.attr$dimnames,index=x.attr$index)
original.attr <- attributes(x)[!names(attributes(x)) %in%
c("dim","dimnames","index","class")]
for(i in names(original.attr)) {
attr(xx,i) <- NULL
}
timeSeries(coredata(xx),charvec=as.POSIXct(format(index(x)),tz="GMT"),format=x.attr$format,
zone=x.attr$FinCenter,FinCenter=x.attr$FinCenter,
recordIDs=x.attr$recordIDs,title=x.attr$title,
documentation=x.attr$documentation,...)
}
#' @rdname as.xts
`as.xts.timeSeries` <-
function(x,dateFormat="POSIXct",FinCenter,recordIDs,title,documentation,..., .RECLASS=FALSE) {
if(missing(FinCenter))
FinCenter <- x@FinCenter
if(missing(recordIDs))
recordIDs <- x@recordIDs
if(missing(title))
title <- x@title
if(missing(documentation))
documentation <- x@documentation
indexBy <- structure(x@positions, class=c("POSIXct","POSIXt"), tzone=FinCenter)
order.by <- do.call(paste('as',dateFormat,sep='.'),list(as.character(indexBy)))
if(.RECLASS) {
xts(as.matrix(x@.Data),
order.by=order.by,
format=x@format,
FinCenter=FinCenter,
recordIDs=recordIDs,
title=title,
documentation=documentation,
.CLASS='timeSeries',
.CLASSnames=c('FinCenter','recordIDs','title','documentation','format'),
.RECLASS=TRUE,
...)
} else {
xts(as.matrix(x@.Data),
order.by=order.by,
...)
}
}
as.timeSeries.xts <- function(x, ...) {
if(!requireNamespace('timeSeries', quietly=TRUE)) {
timeSeries <- function(...) message("package 'timeSeries' is required")
} else {
timeSeries <- timeSeries::timeSeries
}
timeSeries(data=coredata(x), charvec=as.character(index(x)), ...)
}
xts/R/Ops.xts.R 0000644 0001762 0000144 00000006141 14654242576 013013 0 ustar ligges users #
# 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 2 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 .
`Ops.xts` <-
function(e1, e2)
{
# determine and output class
# use 'e1' first because e2 is missing for unary +/-/!
if(inherits(e1, "xts")) {
# e1 could be a derived class; use its class for output
# NOTE: we want the output to be an xts object even if e2 is a derived
# class, because Ops.xts() might not create an appropriate derived class
# object
out_class <- class(e1)
} else {
# if 'e1' isn't xts, then e2 must be xts or a derived class, otherwise
# this method wouldn't have been called
out_class <- class(e2)
}
e <- if (missing(e2)) {
.Class <- "matrix"
NextMethod(.Generic)
}
else if (any(nchar(.Method) == 0)) {
.Class <- "matrix"
NextMethod(.Generic)
}
else {
if( NROW(e1)==NROW(e2) && identical(.index(e1),.index(e2)) ) {
.Class <- "matrix"
NextMethod(.Generic)
} else {
tmp.e1 <- merge.xts(e1, e2, all=FALSE, retclass=FALSE, retside=c(TRUE,FALSE), check.names=FALSE)
e2 <- merge.xts(e2, e1, all=FALSE, retclass=FALSE, retside=c(TRUE,FALSE), check.names=FALSE)
e1 <- tmp.e1
.Class <- "matrix"
NextMethod(.Generic)
}
}
# These return an object the same class as input(s); others return a logical object
if(.Generic %in% c("+","-","*","/","^","%%","%/%")) {
e <- .Call(C_add_class, e, out_class)
}
if(length(e)==0) {
if(is.xts(e1)) {
idx <- .index(e1)
} else {
idx <- .index(e2)
}
idx[] <- idx[0]
attr(e,'index') <- idx
}
dn <- dimnames(e)
if(!is.null(dn[[1L]])) {
if(is.null(dn[[2L]])) {
attr(e, "dimnames") <- NULL
} else {
dimnames(e) <- list(NULL, dn[[2L]])
}
}
if(is.null(attr(e,'index'))) {
if(is.xts(e1)) {
e <- .xts(e, .index(e1), tclass(e1), tzone(e1), tformat = tformat(e1))
} else if(is.xts(e2)) {
e <- .xts(e, .index(e2), tclass(e2), tzone(e2), tformat = tformat(e2))
} else {
# neither have class = ('xts', 'zoo'), because they were overwritten
# by the result of merge(..., retclass = FALSE). But they still have
# an 'index' attribute.
ix <- .index(e1)
if (is.null(ix)) {
ix <- .index(e2)
}
e <- .xts(e, ix, tclass(ix), tzone(ix), tformat = tformat(ix))
}
if(is.null(dim(e1)) && is.null(dim(e2)))
dim(e) <- NULL
}
attr(e, "names") <- NULL
e
}
xts/R/data.frame.R 0000644 0001762 0000144 00000004506 14654242576 013442 0 ustar ligges users #
# 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 2 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 .
# functions to handle data.frame <--> xts conversions
`re.data.frame` <-
function(x,...) {
data.frame(x,...)
}
#' @rdname as.xts
`as.xts.data.frame` <-
function(x,
order.by,
dateFormat = "POSIXct",
frequency = NULL,
...,
.RECLASS = FALSE)
{
# Should allow 'order.by' to be a vector of dates or a scaler
# representing the column number to use.
if(missing(order.by)) {
order_by_ <- try({
coerce.rownames <- paste("as", dateFormat, sep = ".")
do.call(coerce.rownames, list(rownames(x)))
}, silent = TRUE)
if(inherits(order_by_, "try-error")) {
# parsing row names failed, so look for a time-based column
time.based.col <- vapply(x, is.timeBased, logical(1))
if(any(time.based.col)) {
# use the first time-based column
which.col <- which.max(time.based.col)
order_by_ <- x[[which.col]]
x <- x[, -which.col, drop = FALSE]
} else {
stop("could not convert row names to a date-time and could not find a time-based column")
}
}
} else {
order_by_ <- order.by
}
if(.RECLASS) {
xx <- xts(x,
order.by=order_by_,
frequency=frequency,
.CLASS='data.frame',
...)
} else {
xx <- xts(x,
order.by=order_by_,
frequency=frequency,
...)
}
xx
}
`as.data.frame.xts` <-
function(x,row.names=NULL,optional=FALSE,...) {
if(missing(row.names))
row.names <- as.character(index(x))
as.data.frame(coredata(x),row.names,optional,...)
}
xts/R/print.R 0000644 0001762 0000144 00000011423 14702273202 012550 0 ustar ligges users #
# 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 2 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 .
#' Print An xts Time-Series Object
#'
#' Method for printing an extensible time-series object.
#'
#' @param x An xts object.
#' @param fmt Passed to [`coredata()`][zoo::coredata] to format the time index.
#' @param \dots Arguments passed to other methods.
#' @param show.rows The number of first and last rows to print if the number of
#' rows is truncated (default 10, or `getOption("xts.print.show.rows")`).
#' @param max.rows The output will contain at most `max.rows` rows before being
#' truncated (default 100, or `getOption("xts.print.max.rows")`).
#'
#' @return Returns `x` invisibly.
#'
#' @author Joshua M. Ulrich
#'
#' @keywords print
#' @examples
#'
#' data(sample_matrix)
#' sample.xts <- as.xts(sample_matrix)
#'
#' # output is truncated and shows first and last 10 observations
#' print(sample.xts)
#'
#' # show the first and last 5 observations
#' print(sample.xts, show.rows = 5)
#'
print.xts <-
function(x,
fmt,
...,
show.rows = 10,
max.rows = 100)
{
check.TZ(x)
nr <- NROW(x)
nc <- NCOL(x)
dots <- list(...)
if (missing(max.rows)) {
# the user didn't specify a value; use the global option value if it's
# set; if it's not set, use the default value
max.rows <- getOption("xts.print.max.rows", max.rows)
}
# 'max' in print.default() takes precedence over 'show.rows'
if (hasArg("max")) {
# 'max' is the number of *elements* (not rows) to print
if (nr < 1) {
show.rows <- 0
} else {
# convert 'max' to 'show.rows'
if (!is.null(dots$max)) {
show.rows <- trunc(dots$max / nc)
}
}
} else if (missing(show.rows)) {
# the user didn't specify a value; use the global option value if it's
# set; if it's not set, use the default value
show.rows <- getOption("xts.print.show.rows", show.rows)
}
if (missing(fmt)) {
fmt <- tformat(x)
}
if (is.null(fmt)) {
fmt <- TRUE
}
if (!hasArg("quote")) {
dots$quote <- FALSE
}
if (!hasArg("right")) {
dots$right <- TRUE
}
if (nr > max.rows && nr > 2 * show.rows) {
# 'show.rows' can't be more than 2*nrow(x) or observations will be printed
# twice, once before the "..." and once after.
seq.row <- seq_len(show.rows)
seq.col <- seq_len(nc)
seq.n <- (nr - show.rows + 1):nr
# format all the index values that will be printed,
# so every row will have the same number of characters
index <- format(index(x)[c(seq.row, seq.n)])
# combine the index values with the '...' separator
index <- c(index[seq.row], "...", index[-c(seq.row, tail(seq.row, 1))])
# as.matrix() to ensure we have dims
# unclass() avoids as.matrix() method dispatch
m <- as.matrix(unclass(x))
# convert to data.frame to format each column individually
m <- data.frame(m[c(seq.row, seq.n), seq.col, drop = FALSE])
m[] <- lapply(m, format)
m <- as.matrix(m)
# insert blank row between top and bottom rows
y <- rbind(utils::head(m, show.rows),
rep("", nc),
utils::tail(m, show.rows))
rownames(y) <- format(index, justify = "right")
colnames(y) <- colnames(m[, seq.col, drop = FALSE])
} else {
y <- coredata(x, fmt)
}
if (length(y) == 0) {
if (!is.null(dim(x))) {
p <- structure(vector(storage.mode(y)), dim = dim(x),
dimnames = list(format(index(x)), colnames(x)))
print(p)
} else {
cat('Data:\n')
print(vector(storage.mode(y)))
cat('\n')
cat('Index:\n')
index <- index(x)
if (length(index) == 0) {
print(index)
} else {
print(str(index))
}
}
} else {
# ensure 'y' has dims and row names
if (is.null(dim(y))) {
y_names <- as.character(index(x))
y <- matrix(y, nrow = length(y), dimnames = list(y_names, NULL))
}
# Create column names as column indexes.
if (is.null(colnames(y))) {
colnames(y) <- paste0("[,", seq_len(ncol(y)), "]")
}
do.call("print", c(list(y), dots))
}
invisible(x)
}
xts/R/period.apply.R 0000644 0001762 0000144 00000020701 14654242576 014041 0 ustar ligges users #
# 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 2 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 .
.mean_by_column_message <-
function(caller)
{
if (getOption("xts.message.period.apply.mean", TRUE)) {
message("NOTE: `", caller, "(..., FUN = mean)` operates by column, unlike other math\n ",
"functions (e.g. median, sum, var, sd). Please use `FUN = colMeans` instead,\n ",
"and use `FUN = function(x) mean(x)` to take the mean of all columns. Set\n ",
"`options(xts.message.period.apply.mean = FALSE)` to suppress this message.")
}
# changing this behavior will break code in the following dependencies:
#
# ATAforecasting/R/ATA_Find_Multi_Freq.R
# bidask/R/utils.R
# dsa/R/HelperFunctions.R # {.tomonth}
# RavenR/inst/doc/Introduction_to_RavenR.R
# RavenR/inst/doc/Introduction_to_RavenR.Rmd
# RavenR/R/rvn_apply_wyearly.R
# RavenR/R/rvn_monthly_vbias.R
# rts/man/apply.monthly.Rd
# rts/man/period.apply.Rd
# RWDataPlyr/R/xts_helperFunctions.R
}
#' Apply Function Over Specified Interval
#'
#' Apply a specified function to data over intervals specified by `INDEX`. The
#' intervals are defined as the observations from `INDEX[k]+1` to `INDEX[k+1]`,
#' for `k = 1:(length(INDEX)-1)`.
#'
#' Similar to the rest of the apply family, `period.apply()` calculates the
#' specified function's value over a subset of data. The primary difference is
#' that `period.apply()` applies the function to non-overlapping intervals of a
#' vector or matrix.
#'
#' Useful for applying functions over an entire data object by any
#' non-overlapping intervals. For example, when `INDEX` is the result of a
#' call to `endpoints()`.
#'
#' `period.apply()` checks that `INDEX` is sorted, unique, starts with 0, and
#' ends with `nrow(x)`. All those conditions are true of vectors returned by
#' `endpoints()`.
#'
#' @param x The data that `FUN` will be applied to.
#' @param INDEX A numeric vector of index breakpoint locations. The vector
#' should begin with 0 and end with `nrow(x)`.
#' @param FUN A function to apply to each interval in `x`.
#' @param \dots Additional arguments for `FUN`.
#'
#' @return An object with `length(INDEX) - 1` observations, assuming `INDEX`
#' starts with 0 and ends with `nrow(x)`.
#'
#' @note When `FUN = mean` the results will contain one column for every
#' column in the input, which is different from other math functions (e.g.
#' `median`, `sum`, `prod`, `sd`, etc.).
#'
#' `FUN = mean` works by column because the default method `stats::mean`
#' previously worked by column for matrices and data.frames. R Core changed the
#' behavior of `mean` to always return one column in order to be consistent
#' with the other math functions. This broke some \pkg{xts} dependencies and
#' `mean.xts()` was created to maintain the original behavior.
#'
#' Using `FUN = mean` will print a message that describes this inconsistency.
#' To avoid the message and confusion, use `FUN = colMeans` to calculate means
#' by column and use `FUN = function(x) mean` to calculate one mean for all the
#' data. Set `options(xts.message.period.apply.mean = FALSE)` to suppress this
#' message.
#'
#' @author Jeffrey A. Ryan, Joshua M. Ulrich
#'
#' @seealso [`endpoints()`] [`apply.monthly()`]
#'
#' @keywords utilities
#' @examples
#'
#' zoo.data <- zoo(rnorm(31)+10,as.Date(13514:13744,origin="1970-01-01"))
#' ep <- endpoints(zoo.data,'weeks')
#' period.apply(zoo.data, INDEX=ep, FUN=function(x) colMeans(x))
#' period.apply(zoo.data, INDEX=ep, FUN=colMeans) #same
#'
#' period.apply(letters,c(0,5,7,26), paste0)
#'
`period.apply` <-
function(x, INDEX, FUN, ...)
{
if (deparse(substitute(FUN))[1] == "mean") {
.mean_by_column_message("period.apply")
}
x <- try.xts(x, error = FALSE)
FUN <- match.fun(FUN)
if(!isOrdered(INDEX)) {
# isOrdered returns FALSE if there are duplicates
INDEX <- sort(unique(INDEX))
}
if(INDEX[1] != 0) {
INDEX <- c(0, INDEX)
}
if(last(INDEX) != NROW(x)) {
INDEX <- c(INDEX, NROW(x))
}
xx <- sapply(1:(length(INDEX) - 1), function(y) {
FUN(x[(INDEX[y] + 1):INDEX[y + 1]], ...)
})
if(is.vector(xx))
xx <- t(xx)
xx <- t(xx)
if(is.null(colnames(xx)) && NCOL(x)==NCOL(xx))
colnames(xx) <- colnames(x)
reclass(xx, x[INDEX])
}
#' @rdname apply.monthly
`apply.daily` <-
function(x,FUN, ...)
{
if (deparse(substitute(FUN))[1] == "mean") {
.mean_by_column_message("apply.daily")
}
ep <- endpoints(x,'days')
period.apply(x,ep,FUN, ...)
}
#' @rdname apply.monthly
`apply.weekly` <-
function(x,FUN, ...)
{
if (deparse(substitute(FUN))[1] == "mean") {
.mean_by_column_message("apply.weekly")
}
ep <- endpoints(x,'weeks')
period.apply(x,ep,FUN, ...)
}
#' Apply Function over Calendar Periods
#'
#' Apply a specified function to each distinct period in a given time series
#' object.
#'
#' Simple mechanism to apply a function to non-overlapping time periods, e.g.
#' weekly, monthly, etc. Different from rolling functions in that this will
#' subset the data based on the specified time period (implicit in the call),
#' and return a vector of values for each period in the original data.
#'
#' Essentially a wrapper to the \pkg{xts} functions `endpoints()` and
#' `period.apply()`, mainly as a convenience.
#'
#' @param x A time-series object coercible to xts.
#' @param FUN A function to apply to each period.
#' @param \dots Additional arguments to `FUN`.
#'
#' @return A vector of results produced by `FUN`, corresponding to the
#' appropriate periods.
#'
#' @note When `FUN = mean` the results will contain one column for every
#' column in the input, which is different from other math functions (e.g.
#' `median`, `sum`, `prod`, `sd`, etc.).
#'
#' `FUN = mean` works by column because the default method `stats::mean`
#' previously worked by column for matrices and data.frames. R Core changed the
#' behavior of `mean` to always return one column in order to be consistent
#' with the other math functions. This broke some \pkg{xts} dependencies and
#' `mean.xts()` was created to maintain the original behavior.
#'
#' Using `FUN = mean` will print a message that describes this inconsistency.
#' To avoid the message and confusion, use `FUN = colMeans` to calculate means
#' by column and use `FUN = function(x) mean` to calculate one mean for all the
#' data. Set `options(xts.message.period.apply.mean = FALSE)` to suppress this
#' message.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`endpoints()`], [`period.apply()`], [`to.monthly()`]
#'
#' @keywords utilities
#' @examples
#'
#' xts.ts <- xts(rnorm(231),as.Date(13514:13744,origin="1970-01-01"))
#'
#' start(xts.ts)
#' end(xts.ts)
#'
#' apply.monthly(xts.ts,colMeans)
#' apply.monthly(xts.ts,function(x) var(x))
#'
`apply.monthly` <-
function(x,FUN, ...)
{
if (deparse(substitute(FUN))[1] == "mean") {
.mean_by_column_message("apply.monthly")
}
ep <- endpoints(x,'months')
period.apply(x,ep,FUN, ...)
}
#' @rdname apply.monthly
`apply.quarterly` <-
function(x,FUN, ...)
{
if (deparse(substitute(FUN))[1] == "mean") {
.mean_by_column_message("apply.quarterly")
}
ep <- endpoints(x,'quarters')
period.apply(x,ep,FUN, ...)
}
#' @rdname apply.monthly
`apply.yearly` <-
function(x,FUN, ...)
{
if (deparse(substitute(FUN))[1] == "mean") {
.mean_by_column_message("apply.yearly")
}
ep <- endpoints(x,'years')
period.apply(x,ep,FUN, ...)
}
period_apply <- function(x, INDEX, FUN, ...) {
fun <- substitute(FUN)
e <- new.env()
if (INDEX[1] != 0) {
INDEX <- c(0, INDEX)
}
if (INDEX[length(INDEX)] != NROW(x)) {
INDEX <- c(INDEX, NROW(x))
}
pl <- .Call(C_xts_period_apply, x, INDEX, fun, e)
.xts(do.call(rbind, pl), .index(x)[INDEX], tclass = tclass(x), tzone = tzone(x))
}
xts/R/index.R 0000644 0001762 0000144 00000032603 14654242576 012546 0 ustar ligges users #
# 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 2 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 .
#' Get and Replace the Class of an xts Index
#'
#' Functions to get and replace an xts object's index values and it's
#' components.
#'
#' An xts object's index is stored internally as the number of seconds since
#' UNIX epoch in the UTC timezone. The `.index()` and `.index<-` functions get
#' and replace the internal numeric value of the index, respectively. These
#' functions are primarily for internal use, but are exported because they may
#' be useful for users.
#'
#' The replacement method also updates the [`tclass()`] and [`tzone()`] of the
#' index to match the class and timezone of the new index, respectively. The
#' `index()` method converts the internal numeric index to the class specified
#' by the 'tclass' attribute and with the timezone specified by the 'tzone'
#' attribute before returning the index values to the user.
#'
#' The `.indexXXX()` functions below extract time components from the internal
#' time index. They return values like the values of [POSIXlt] components.
#'
#' \describe{
#' \item{`.indexsec`}{0 - 61: seconds of the minute (local time)}
#' \item{`.indexmin`}{0 - 59: minutes of the hour (local time)}
#' \item{`.indexhour`}{0 - 23: hours of the day (local time)}
#' \item{`.indexDate`}{date as seconds since the epoch (UTC *not local time*}
#' \item{`.indexday`}{date as seconds since the epoch (UTC *not local time*}
#' \item{`.indexwday`}{0 - 6: day of the week (Sunday - Saturday, local time)}
#' \item{`.indexmday`}{1 - 31: day of the month (local time)}
#' \item{`.indexweek`}{weeks since the epoch (UTC *not local time*}
#' \item{`.indexmon`}{0 - 11: month of the year (local time)}
#' \item{`.indexyear`}{years since 1900 (local time)}
#' \item{`.indexyday`}{0 - 365: day of the year (local time, 365 only in leap years)}
#' \item{`.indexisdst`}{1, 0, -1: Daylight Saving Time flag. Positive if
#' Daylight Saving Time is in effect, zero if not, negative if unknown.}
#' }
#'
#' Changes in timezone, index class, and index format internal structure, by
#' \pkg{xts} version:
#'
#' \describe{
#' \item{Version 0.12.0:}{The `.indexTZ`, `.indexCLASS` and `.indexFORMAT`
#' attributes are no longer stored on xts objects, only on the index itself.
#' \cr\cr
#' The `indexTZ()`, `indexClass()`, and `indexFormat()` functions (and
#' their respective replacement methods) are deprecated in favor of their
#' respective `tzone()`, `tclass()`, and `tformat()` versions. The previous
#' versions throw a warning that they're deprecated, but they will continue
#' to work. They will never be removed or throw an error. Ever.
#' \cr\cr
#' The new versions are careful to look for the old attributes on the xts
#' object, in case they're ever called on an xts object that was created prior
#' to the attributes being added to the index itself.
#' \cr\cr
#' You can set `options(xts.warn.index.missing.tzone = TRUE)` and
#' `options(xts.warn.index.missing.tclass = TRUE)` to identify xts objects
#' that do not have a 'tzone' or 'tclass' attribute on the index, even if
#' there is a 'tzone' or 'tclass' attribute on the xts object itself. The
#' warnings will be thrown when the object is printed.
#' Use `x <- as.xts(x)` to update these objects to the new structure.}
#'
#' \item{Version 0.9.8:}{The index timezone is now set to "UTC" for time classes
#' that do not have any intra-day component (e.g. days, months, quarters).
#' Previously the timezone was blank, which meant "local time" as determined by
#' \R and the OS.}
#'
#' \item{Version 0.9.2:}{There are new get/set methods for the timezone, index
#' class, and index format attributes: `tzone()` and, `tzone<-`, `tclass()`
#' and `tclass<-`, and `tformat()` and `tformat<-`. These new functions are
#' aliases to their `indexTZ()`, `indexClass()`, and `indexFormat()`
#' counterparts.}
#'
#' \item{Version 0.7.5:}{The timezone, index class, and index format were added
#' as attributes to the index itself, as 'tzone', 'tclass', and 'tformat',
#' respectively. This is in order to remove those three attributes from the xts
#' object, so they're only on the index itself.
#' \cr\cr
#' The `indexTZ()`, `indexClass()`, and `indexFormat()` functions (and their
#' respective replacement methods) will continue to work as in prior \pkg{xts}
#' versions. The attributes on the index take priority over their respective
#' counterparts that may be on the xts object.}
#'
#' \item{Versions 0.6.4 and prior:}{Objects track their timezone and index class
#' in their '.indexTZ' and '.indexCLASS' attributes, respectively.}
#' }
#'
#' @param x An xts object.
#' @param value A new time index value.
#' @param \dots Arguments passed to other methods.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`tformat()`] describes how the index values are formatted when
#' printed, [`tclass()`] documents how \pkg{xts} handles the index class, and
#' [`tzone()`] has more information about index timezone settings.
#'
#' @keywords ts utilities
#' @examples
#'
#' x <- timeBasedSeq('2010-01-01/2010-01-01 12:00/H')
#' x <- xts(seq_along(x), x)
#'
#' # the index values, converted to 'tclass' (POSIXct in this case)
#' index(x)
#' class(index(x)) # POSIXct
#' tclass(x) # POSIXct
#'
#' # the internal numeric index
#' .index(x)
#' # add 1 hour (3600 seconds) to the numeric index
#' .index(x) <- index(x) + 3600
#' index(x)
#'
#' y <- timeBasedSeq('2010-01-01/2010-01-02 12:00')
#' y <- xts(seq_along(y), y)
#'
#' # Select all observations in the first 6 and last 3 minutes of the
#' # 8th and 15th hours on each day
#' y[.indexhour(y) %in% c(8, 15) & .indexmin(y) %in% c(0:5, 57:59)]
#'
#' i <- 0:60000
#' focal_date <- as.numeric(as.POSIXct("2018-02-01", tz = "UTC"))
#' y <- .xts(i, c(focal_date + i * 15), tz = "UTC", dimnames = list(NULL, "value"))
#'
#' # Select all observations for the first minute of each hour
#' y[.indexmin(y) == 0]
#'
#' # Select all observations on Monday
#' mon <- y[.indexwday(y) == 1]
#' head(mon)
#' tail(mon)
#' unique(weekdays(index(mon))) # check
#'
#' # Disjoint time of day selections
#'
#' # Select all observations between 08:30 and 08:59:59.9999 or between 12:00 and 12:14:59.99999:
#' y[.indexhour(y) == 8 & .indexmin(y) >= 30 | .indexhour(y) == 12 & .indexmin(x) %in% 0:14]
#'
#' ### Compound selections
#'
#' # Select all observations for Wednesdays or Fridays between 9am and 4pm (exclusive of 4pm):
#' y[.indexwday(y) %in% c(3, 5) & (.indexhour(y) %in% c(9:15))]
#'
#' # Select all observations on Monday between 8:59:45 and 09:04:30:
#'
#' y[.indexwday(y) == 1 & (.indexhour(y) == 8 & .indexmin(y) == 59 & .indexsec(y) >= 45 |
#' .indexhour(y) == 9 &
#' (.indexmin(y) < 4 | .indexmin(y) == 4 & .indexsec(y) <= 30))]
#'
#' i <- 0:30000
#' u <- .xts(i, c(focal_date + i * 1800), tz = "UTC", dimnames = list(NULL, "value"))
#'
#' # Select all observations for January or February:
#' u[.indexmon(u) %in% c(0, 1)]
#'
#' # Select all data for the 28th to 31st of each month, excluding any Fridays:
#' u[.indexmday(u) %in% 28:31 & .indexwday(u) != 5]
#'
#' # Subset by week since origin
#' unique(.indexweek(u))
#' origin <- xts(1, as.POSIXct("1970-01-01"))
#' unique(.indexweek(origin))
#'
#' # Select all observations in weeks 2515 to 2517.
#' u2 <- u[.indexweek(u) %in% 2515:2517]
#' head(u2); tail(u2)
#'
#' # Select all observations after 12pm for day 50 and 51 in each year
#' u[.indexyday(u) %in% 50:51 & .indexhour(u) >= 12]
#'
index.xts <-
function(x, ...) {
value <- tclass(x)
if(is.null(value) || !nzchar(value[1L])) {
warning("index does not have a ", sQuote("tclass"), " attribute\n",
" returning c(\"POSIXct\", \"POSIXt\")")
ix <- .index(x)
attr(ix, "tclass") <- attr(ix, "class") <- c("POSIXct", "POSIXt")
return(ix)
}
# if tclass is Date, POSIXct time is set to 00:00:00 GMT. Convert here
# to avoid ugly and hard to debug TZ conversion. What will this break?
if(value[[1]] == "Date")
#return( as.Date(.index(x)/86400) )
return( structure(.index(x) %/% 86400, class="Date"))
#x.index <- structure(.index(x), class=c("POSIXct","POSIXt"))
x.index <- .POSIXct(.index(x), tz=attr(.index(x), "tzone"))
if(!is.list(value))
value <- as.list(value)
switch(value[[1]],
multitime = as.Date(as.character(x.index)),
POSIXt = {
# get specific ct/lt value
do.call(paste('as',value[[2]],sep='.'),list(x.index))
},
POSIXct = as.POSIXct(x.index),
POSIXlt = as.POSIXlt(x.index),
timeDate = {
if(!requireNamespace("timeDate", quietly=TRUE))
stop("package:",dQuote("timeDate"),"cannot be loaded.")
timeDate::as.timeDate(x.index)
},
chron = ,
dates = {
if(!requireNamespace("chron", quietly=TRUE))
stop("package:",dQuote("chron"),"cannot be loaded.")
chron::as.chron(format(x.index))
},
#Date = as.Date(as.character(x.index)), # handled above
yearmon = as.yearmon(x.index),
yearqtr = as.yearqtr(x.index),
stop(paste('unsupported',sQuote('tclass'),'indexing type:',value[[1]]))
)
}
#' @rdname index.xts
`index<-.xts` <- function(x, value) {
if(length(index(x)) != length(value)) stop('length of index vectors does not match')
if( !timeBased(value) )
stop(paste('unsupported',sQuote('index'),
'index type of class',sQuote(class(value))))
# copy original index attributes
ixattr <- attributes(attr(x, 'index'))
# set index to the numeric value of the desired index class
if(inherits(value,"Date"))
attr(x, 'index') <- structure(unclass(value)*86400, tclass="Date", tzone="UTC")
else attr(x, 'index') <- as.numeric(as.POSIXct(value))
# ensure new index is sorted
if(!isOrdered(.index(x), strictly=FALSE))
stop("new index needs to be sorted")
# set tclass attribute to the end-user specified class
attr(attr(x, 'index'), 'tclass') <- class(value)
# set tzone attribute
if(isClassWithoutTZ(object = value)) {
attr(attr(x, 'index'), 'tzone') <- 'UTC'
} else {
if (is.null(attr(value, 'tzone'))) {
# ensure index has tzone attribute if value does not
attr(attr(x, 'index'), 'tzone') <- ixattr[["tzone"]]
} else {
attr(attr(x, 'index'), 'tzone') <- attr(value, 'tzone')
}
}
return(x)
}
#' @rdname index.xts
`time<-.xts` <- `index<-.xts`
#' @rdname index.xts
time.xts <- index.xts
#' @rdname index.xts
`.index` <- function(x, ...) {
if(is.list(attr(x, "index"))) {
attr(x, 'index')[[1]]
} else attr(x, "index")
}
#' @rdname index.xts
`.index<-` <- function(x, value) {
if(timeBased(value)) {
if(inherits(value, 'Date')) {
attr(x, 'index') <- as.numeric(value)
} else {
attr(x, 'index') <- as.numeric(as.POSIXct(value))
}
} else
if(is.numeric(value)) {
attr(value, 'tclass') <- tclass(x)
attr(value, 'tzone') <- tzone(x)
attr(x, 'index') <- value
} else stop(".index is used for low level operations - data must be numeric or timeBased")
return(x)
}
#' @rdname index.xts
`.indexsec` <- function(x) {
as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$sec
}
#' @rdname index.xts
`.indexmin` <- function(x) {
as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$min
}
#' @rdname index.xts
`.indexhour` <- function(x) {
as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$hour
}
#' @rdname index.xts
`.indexmday` <- function(x) {
as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$mday
}
#' @rdname index.xts
`.indexmon` <- function(x) {
as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$mon
}
#' @rdname index.xts
`.indexyear` <- function(x) {
as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$year
}
#' @rdname index.xts
`.indexwday` <- function(x) {
as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$wday
}
#' @rdname index.xts
`.indexbday` <- function(x) {
# is business day T/F
as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$wday %% 6 > 0
}
#' @rdname index.xts
`.indexyday` <- function(x) {
as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$yday
}
#' @rdname index.xts
`.indexisdst` <- function(x) {
as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$isdst }
#' @rdname index.xts
`.indexDate` <- function(x) {
.index(x) %/% 86400L
}
#' @rdname index.xts
`.indexday` <- .indexDate
#' @rdname index.xts
`.indexweek` <- function(x) {
(.index(x) + (3 * 86400)) %/% 86400 %/% 7
}
#' @rdname index.xts
`.indexyweek` <- function(x) {
((.index(x) + (3 * 86400)) %/% 86400 %/% 7) -
((startOfYear() * 86400 + (3 * 86400)) %/% 86400 %/% 7)[.indexyear(x) + 1]
}
#' @rdname index.xts
`convertIndex` <-
function(x,value) {
tclass(x) <- value
x
}
.update_index_attributes <- function(x) {
suppressWarnings({
tclass(x) <- tclass(x)
tzone(x) <- tzone(x)
})
return(x)
}
xts/R/toperiod.R 0000644 0001762 0000144 00000030432 14654242576 013262 0 ustar ligges users #
# 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 2 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 .
#' Convert time series data to an OHLC series
#'
#' Convert an OHLC or univariate object to a specified periodicity lower than
#' the given data object. For example, convert a daily series to a monthly
#' series, or a monthly series to a yearly one, or a one minute series to an
#' hourly series.
#'
#' The result will contain the open and close for the given period, as well as
#' the maximum and minimum over the new period, reflected in the new high and
#' low, respectively. Aggregate volume will also be calculated if applicable.
#'
#' An easy and reliable way to convert one periodicity of data into any new
#' periodicity. It is important to note that all dates will be aligned to the
#' *end* of each period by default - with the exception of `to.monthly()` and
#' `to.quarterly()`, which use the \pkg{zoo} package's [yearmon][zoo::zoo] and
#' [yearqtr][zoo::zoo] classes, respectively.
#'
#' Valid period character strings include: `"seconds"`, `"minutes"`, `"hours"`,
#' `"days"`, `"weeks"`, `"months"`, `"quarters"`, and `"years"`. These are
#' calculated internally via [`endpoints()`]. See that function's help page for
#' further details.
#'
#' To adjust the final indexing style, it is possible to set `indexAt` to one
#' of the following: \sQuote{yearmon}, \sQuote{yearqtr}, \sQuote{firstof},
#' \sQuote{lastof}, \sQuote{startof}, or \sQuote{endof}. The final index will
#' then be `yearmon`, `yearqtr`, the first time of the period, the last time
#' of the period, the starting time in the data for that period, or the ending
#' time in the data for that period, respectively.
#'
#' It is also possible to pass a single time series, such as a univariate
#' exchange rate, and return an OHLC object of lower frequency - e.g. the
#' weekly OHLC of the daily series.
#'
#' Setting `drop.time = TRUE` (the default) will convert a series that includes
#' a time component into one with just a date index, since the time component
#' is often of little value in lower frequency series.
#'
#' @param x A univariate or OHLC type time-series object.
#' @param period Period to convert to. See details.
#' @param indexAt Convert final index to new class or date. See details.
#' @param drop.time Remove time component of POSIX datestamp (if any)?
#' @param k Number of sub periods to aggregate on (only for minutes and
#' seconds).
#' @param name Override column names?
#' @param OHLC Should an OHLC object be returned? (only `OHLC = TRUE`
#' currently supported)
#' @param \dots Additional arguments.
#'
#' @return An object of the original type, with new periodicity.
#'
#' @note In order for this function to work properly on OHLC data, it is
#' necessary that the Open, High, Low and Close columns be names as such;
#' including the first letter capitalized and the full spelling found.
#' Internally a call is made to reorder the data into the correct column order,
#' and then a verification step to make sure that this ordering and naming has
#' succeeded. All other data formats must be aggregated with functions such as
#' `aggregate()` and `period.apply()`.
#'
#' This method should work on almost all time-series-like objects. Including
#' \sQuote{timeSeries}, \sQuote{zoo}, \sQuote{ts}, and \sQuote{irts}. It is
#' even likely to work well for other data structures - including
#' \sQuote{data.frames} and \sQuote{matrix} objects.
#'
#' Internally a call to `as.xts()` converts the original `x` into the
#' universal xts format, and then re-converts back to the original type.
#'
#' A special note with respect to \sQuote{ts} objects. As these are strictly
#' regular they may include `NA` values. These are removed before aggregation,
#' though replaced before returning the result. This inevitably leads to many
#' additional `NA` values in the result. Consider using an xts object or
#' converting to xts using `as.xts()`.
#'
#' @author Jeffrey A. Ryan
#'
#' @keywords utilities
#' @aliases to_period
#' @examples
#'
#' data(sample_matrix)
#'
#' samplexts <- as.xts(sample_matrix)
#'
#' to.monthly(samplexts)
#' to.monthly(sample_matrix)
#'
#' str(to.monthly(samplexts))
#' str(to.monthly(sample_matrix))
#'
to.period <- to_period <- function(x, period='months', k=1, indexAt=NULL, name=NULL, OHLC=TRUE, ...) {
if(missing(name)) name <- deparse(substitute(x))
xo <- x
x <- try.xts(x)
if(NROW(x)==0 || NCOL(x)==0)
stop(sQuote("x")," contains no data")
if(any(is.na(x))) {
x <- na.omit(x)
warning("missing values removed from data")
}
if(is.character(period)) {
ep <- endpoints(x, period, k)
} else {
if(!is.numeric(period)) {
stop("'period' must be a character or a vector of endpoint locations")
}
if(!missing("k")) {
warning("'k' is ignored when using custom 'period' locations")
}
if(!is.null(indexAt)) {
warning("'indexAt' is ignored when using custom 'period' locations")
indexAt <- NULL
}
ep <- as.integer(period)
# ensure 'ep' starts with 0 and ends with nrow(x)
if(ep[1] != 0) {
ep <- c(0L, ep)
}
if (ep[length(ep)] != NROW(x)) {
ep <- c(ep, NROW(x))
}
}
if(!OHLC) {
xx <- x[ep, ]
} else {
if(!is.null(indexAt)) {
index_at <- switch(indexAt,
"startof" = TRUE, # start time of period
"endof" = FALSE, # end time of period
FALSE
)
} else index_at <- FALSE
# make suitable name vector
cnames <- c("Open", "High", "Low", "Close")
if (has.Vo(x))
cnames <- c(cnames, "Volume")
if (has.Ad(x) && is.OHLC(x))
cnames <- c(cnames, "Adjusted")
cnames <- paste(name,cnames,sep=".")
if(is.null(name))
cnames <- NULL
xx <- .Call(C_toPeriod,
x,
ep,
has.Vo(x), has.Vo(x,which=TRUE),
has.Ad(x) && is.OHLC(x),
index_at,
cnames)
}
if(!is.null(indexAt)) {
if(indexAt=="yearmon" || indexAt=="yearqtr")
tclass(xx) <- indexAt
if(indexAt=="firstof") {
ix <- as.POSIXlt(c(.index(xx)), tz=tzone(xx))
if(period %in% c("years","months","quarters","days"))
index(xx) <- firstof(ix$year + 1900, ix$mon + 1)
else
index(xx) <- firstof(ix$year + 1900, ix$mon + 1, ix$mday,
ix$hour, ix$min, ix$sec)
}
if(indexAt=="lastof") {
ix <- as.POSIXlt(c(.index(xx)), tz=tzone(xx))
if(period %in% c("years","months","quarters","days"))
index(xx) <- as.Date(lastof(ix$year + 1900, ix$mon + 1))
else
index(xx) <- lastof(ix$year + 1900, ix$mon + 1, ix$mday,
ix$hour, ix$min, ix$sec)
}
}
reclass(xx,xo)
}
#' @rdname to.period
`to.minutes` <-
function(x,k,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
if(missing(k)) k <- 1
to.period(x,'minutes',k=k,name=name,...)
}
#' @rdname to.period
`to.minutes3` <-
function(x,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
to.period(x,'minutes',k=3,name=name,...)
}
#' @rdname to.period
`to.minutes5` <-
function(x,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
to.period(x,'minutes',k=5,name=name,...)
}
#' @rdname to.period
`to.minutes10` <-
function(x,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
to.period(x,'minutes',k=10,name=name,...)
}
#' @rdname to.period
`to.minutes15` <-
function(x,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
to.period(x,'minutes',k=15,name=name,...)
}
#' @rdname to.period
`to.minutes30` <-
function(x,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
to.period(x,'minutes',k=30,name=name,...)
}
#' @rdname to.period
`to.hourly` <-
function(x,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
to.period(x,'hours',name=name,...)
}
#' @rdname to.period
`to.daily` <-
function(x,drop.time=TRUE,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
x <- to.period(x,'days',name=name,...)
if(drop.time) x <- .drop.time(x)
return(x)
}
#' @rdname to.period
`to.weekly` <-
function(x,drop.time=TRUE,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
x <- to.period(x,'weeks',name=name,...)
if(drop.time) x <- .drop.time(x)
return(x)
}
#' @rdname to.period
`to.monthly` <-
function(x,indexAt='yearmon',drop.time=TRUE,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
x <- to.period(x,'months',indexAt=indexAt,name=name,...)
if(drop.time) x <- .drop.time(x)
return(x)
}
#' @rdname to.period
`to.quarterly` <-
function(x,indexAt='yearqtr',drop.time=TRUE,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
x <- to.period(x,'quarters',indexAt=indexAt,name=name,...)
if(drop.time) x <- .drop.time(x)
return(x)
}
#' @rdname to.period
`to.yearly` <-
function(x,drop.time=TRUE,name,...)
{
if(missing(name)) name <- deparse(substitute(x))
x <- to.period(x,'years',name=name,...)
if(drop.time) x <- .drop.time(x)
return(x)
}
`.drop.time` <-
function(x) {
# function to remove HHMMSS portion of time index
xts.in <- is.xts(x) # is the input xts?
if(!xts.in) # if not, try to convert to xts
x <- try.xts(x, error=FALSE)
if(is.xts(x)) {
# if x is xts, drop HHMMSS from index
if(any(tclass(x)=='POSIXt')) {
# convert index to Date
index(x) <- as.Date(as.POSIXlt(index(x)))
tclass(x) <- "Date" # set tclass to Date
}
if(isClassWithoutTZ(tclass(x))) {
tzone(x) <- "UTC" # set tzone to UTC
}
# force conversion, even if we didn't set tclass to Date
# because indexAt yearmon/yearqtr won't drop time from index
index(x) <- index(x)
if(xts.in) x # if input already was xts
else reclass(x) # if input wasn't xts, but could be converted
} else x # if input wasn't xts, and couldn't be converted
}
`by.period` <-
function(x, FUN, on=Cl, period="days", k=1, fill=na.locf, ...) {
# aggregate 'x' to a higher periodicity, apply 'FUN' to the 'on' columns
# of the aggregate, then merge the aggregate results with 'x' and fill NAs
# with na.locf. E.g. you can apply a 5-day SMA of volume to tick data.
x <- try.xts(x, error = FALSE)
FUN <- match.fun(FUN)
on <- match.fun(on) # Allow function or name
agg <- to.period(x, period, k, ...)
res <- FUN(on(agg), ...)
full <- merge(.xts(NULL,index(x)),res)
full <- fill(full) # Allow function or value
return(full)
}
`to.frequency` <-
function(x, by, k=1, name=NULL, OHLC=TRUE, ...) {
# similar to to.period, but aggregates on something other than time.
# E.g. aggregate by volume, where a "period" is 10% of the 5-day volume SMA.
# Most code pulled from to.period
if(missing(name)) name <- deparse(substitute(x))
xo <- x
x <- try.xts(x)
if(any(is.na(x))) {
x <- na.omit(x)
warning("missing values removed from data")
}
# make suitable name vector
cnames <- c("Open", "High", "Low", "Close")
if (has.Vo(x))
cnames <- c(cnames, "Volume")
if (has.Ad(x) && is.OHLC(x))
cnames <- c(cnames, "Adjusted")
cnames <- paste(name,cnames,sep=".")
if(is.null(name))
cnames <- NULL
# start to.frequency-specific code
if (missing(by)) by <- rep(1L, nrow(x))
byVec <- cumsum(by)
bins <- byVec %/% k
# ep contents must have the same format as output generated by endpoints():
# first element must be zero and last must be nrow(x)
ep <- c(0L, which(diff(bins) != 0))
if (ep[length(ep)] != nrow(bins)) ep <- c(ep, nrow(bins))
# end to.frequency-specific code
xx <- .Call(C_toPeriod,
x,
ep,
has.Vo(x), has.Vo(x,which=TRUE),
has.Ad(x) && is.OHLC(x),
FALSE,
cnames)
reclass(xx,xo)
}
xts/R/timeDate.R 0000644 0001762 0000144 00000001564 14654242576 013175 0 ustar ligges users #
# 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 2 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 .
#' @rdname as.xts
as.xts.timeDate <- function(x, ...)
{
xts(x=NULL, order.by=x)
}
xts/R/str.R 0000644 0001762 0000144 00000006257 14671414605 012246 0 ustar ligges users #
# 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 2 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 .
`str.xts` <-
function(object, ..., ncols = 5)
{
is.data.empty <- is.null(dim(object)) || sum(dim(object)) == 0
is.zero.index <- (length(.index(object)) == 0)
nr <- NROW(object)
nc <- ifelse(is.data.empty, 0, NCOL(object))
# "zero-length" xts
# * index length == 0, but tclass and tzone are set
# * NROW == 0
# * NCOL > 0 and may have column names
# examples:
# str(.xts(1, 1)["1900"])
# str(.xts(cbind(a = 1, b = 2), 1)["1900"])
is.zero.length <- (is.zero.index && nr == 0 && !is.data.empty)
# "zero-width" xts
# * index length > 0
# * NROW == 0
# * NCOL == 0
# example:
# str(.xts(, 1:5))
is.zero.width <- (!is.zero.index && is.data.empty)
# "empty" xts
# * index length == 0, but tclass and tzone are set
# * NROW == 0
# * NCOL == 0
# example:
# str(.xts(, numeric(0)))
# str(.xts(matrix()[0,0], numeric(0)))
is.empty <- (is.zero.index && is.data.empty)
if (is.empty) {
header <- "An empty xts object"
} else if (is.zero.length) {
header <- "A zero-length xts object"
} else {
# zero-width and regular xts objects
if (is.zero.width) {
header <- "A zero-width xts object on"
} else {
header <- "An xts object on"
}
time.range <- sub("/", " / ", .makeISO8601(object), fixed = TRUE)
header <- paste(header, time.range, "containing:")
}
cat(header, "\n")
# Data
cat(sprintf(" Data: %s [%d, %d]\n",
storage.mode(object), nr, nc))
# Column names
cnames <- colnames(object)
if (!is.null(cnames)) {
if (nc > ncols) {
more <- nc - ncols
cname.str <- sprintf("%s ... with %d more %s",
paste(cnames[seq_len(ncols)], collapse = ", "),
more,
ifelse(more > 1, "columns", "column"))
} else {
cname.str <- paste(colnames(object), collapse = ", ")
}
cat(sprintf(" Columns: %s\n", cname.str))
}
# Index
cat(sprintf(" Index: %s [%d] (TZ: \"%s\")\n",
paste(tclass(object), collapse = ","),
length(.index(object)),
tzone(object)))
if (!is.null(CLASS(object))) {
cat(sprintf(" Original class: '%s'\n", CLASS(object)))
}
xts.attr <- xtsAttributes(object)
if (!is.null(xts.attr)) {
cat(" xts Attributes:\n")
str(xts.attr, ..., comp.str = " $ ", no.list = TRUE)
}
invisible(NULL)
}
xts/R/start.R 0000644 0001762 0000144 00000001713 14654242576 012572 0 ustar ligges users #
# 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 2 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 .
`start.xts` <-
function(x, ...) {
index(x[1,])
}
`end.xts` <-
function(x, ...) {
if(length(x)==0) {
index(x[length(.index(x)),])
} else
index(x[NROW(x),])
}
xts/R/origin.fix.R 0000644 0001762 0000144 00000003604 14654242576 013512 0 ustar ligges users #
# 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 2 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 .
# fixes for R new/broken as.Date, as.POSIXlt and as.POSIXct
# hopefully to be removed when remedied in R
# taken directly from 'base', with origin set to '1970-01-01' (1970-01-01)
`as.Date.numeric` <- function(x, origin='1970-01-01', ...) {
as.Date(origin,...) + x
}
`as.POSIXct.numeric` <- function(x, tz="", origin='1970-01-01', ...) {
structure(x, class=c("POSIXct", "POSIXt"))
}
`as.POSIXlt.numeric` <- function(x, tz="", origin='1970-01-01', ...) {
as.POSIXlt(as.POSIXct(origin,tz="UTC",...) + x, tz=tz)
}
as.POSIXct.Date <- function(x, ...)
{
as.POSIXct(as.character(x))
}
as.Date.POSIXct <- function(x, ...)
{
as.Date(strftime(x))
}
as.POSIXlt.Date <- function(x, ...)
{
as.POSIXlt(as.POSIXct.Date(x))
}
as.POSIXct.dates <- function(x, ...)
{
# need to implement our own method to correctly handle TZ
structure(as.POSIXct(as.POSIXlt(x, tz="GMT"), tz="GMT"),class=c("POSIXct","POSIXt"))
}
as.chron.POSIXct <- function(x, ...)
{
if(!requireNamespace('chron', quietly=TRUE))
as.chron <- function(...) message("package 'chron' required")
structure(as.chron(as.POSIXlt(as.character(x))))
}
xts/R/list.R 0000644 0001762 0000144 00000002132 14654242576 012404 0 ustar ligges users #
# 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 2 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 .
as.list.xts <- function(x, ...)
{
if( NCOL(x) == 1 )
return(structure(list(x),.Names=colnames(x)))
cindex <- cnames <- colnames(x)
if(is.null(cnames)) {
cindex <- 1:NCOL(x)
cnames <- paste("x",cindex,sep=".")
}
names(cindex) <- cnames
lapply(cindex,
function(f) x[,f], ...)
}
xts/R/dimnames.R 0000644 0001762 0000144 00000004120 14654242576 013225 0 ustar ligges users #
# 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 2 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 .
# dimnames will return the actual dimnames of the xts object
# dimnames<-.xts will force the rownames to always be NULL
#' Dimnames of an xts Object
#'
#' Get or set dimnames of an xts object.
#'
#' For efficienty, xts objects do not have rownames (unlike zoo objects).
#' Attempts to set rownames on an xts object will silently set them to `NULL`.
#' This is done for internal compatibility reasons, as well as to provide
#' consistency in performance regardless of object use.
#'
#' @param x An xts object.
#' @param value A two element list. See Details.
#'
#' @return A list or character string containing coerced row names and/or
#' actual column names.
#'
#' Attempts to set rownames on xts objects via rownames or dimnames will
#' silently fail.
#'
#' @note Unlike zoo, all xts objects have dimensions. xts objects cannot be
#' plain vectors.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`xts()`]
#'
#' @keywords misc
#' @examples
#'
#' x <- xts(1:10, Sys.Date()+1:10)
#' dimnames(x)
#' rownames(x)
#' rownames(x) <- 1:10
#' rownames(x)
#' str(x)
#'
`dimnames.xts` <-
function(x) {
#list(NULL, colnames(unclass(x)))
.Call(C_dimnames_zoo,x);
#list(as.character(index(x)), colnames(unclass(x)))
}
#' @rdname dimnames.xts
`dimnames<-.xts` <-
function(x, value) {
.Call(C_xts_set_dimnames, x, value)
}
xts/R/irts.R 0000644 0001762 0000144 00000003017 14654242576 012415 0 ustar ligges users #
# 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 2 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 .
# methods for tseries::irts
`re.irts` <-
function(x,...) {
if(!requireNamespace('tseries', quietly=TRUE)) {
irts <- function(...) message("package 'tseries' is required for re.irts")
} else {
irts <- tseries::irts
}
tclass(x) <- "POSIXct"
xx <- coredata(x)
# rownames(xx) <- attr(x,'irts.rownames')
irts(index(x),xx)
}
#' @rdname as.xts
`as.xts.irts` <-
function(x,order.by,frequency=NULL,...,.RECLASS=FALSE) {
if(.RECLASS) {
xx <- xts(x=x$value,
order.by=x$time,
frequency=frequency,
.CLASS='irts',
# irts.rownames=rownames(x$value),
...)
} else {
xx <- xts(x=x$value,
order.by=x$time,
frequency=frequency,
...)
}
xx
}
xts/R/nperiods.R 0000644 0001762 0000144 00000004454 14654242576 013265 0 ustar ligges users #
# 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 2 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 .
#' @rdname ndays
`nseconds` <-
function(x) {
length(endpoints(x,on='seconds'))-1
}
#' @rdname ndays
`nminutes` <-
function(x) {
length(endpoints(x,on='minutes'))-1
}
#' @rdname ndays
`nhours` <-
function(x) {
length(endpoints(x,on='hours'))-1
}
#' Number of Periods in Data
#'
#' Calculate the number of specified periods in a given time series like data
#' object.
#'
#' Essentially a wrapper to `endpoints()` with the appropriate period
#' specified. The result is the number of endpoints found.
#'
#' As a compromise between simplicity and accuracy, the results will always
#' round up to the nearest complete period. Subtract 1 from the result to
#' get the completed periods.
#'
#' For finer grain detail one should call the higher frequency functions.
#'
#' An alternative summary can be found with `periodicity(x)` and
#' `unclass(periodicity(x))`.
#'
#' @param x A time-based object.
#'
#' @return The number of respective periods in `x`.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`endpoints()`]
#'
#' @keywords utilities
#' @examples
#'
#' \dontrun{
#' getSymbols("QQQQ")
#'
#' ndays(QQQQ)
#' nweeks(QQQQ)
#' }
#'
`ndays` <-
function(x) {
length(endpoints(x,on='days'))-1
}
#' @rdname ndays
`nweeks` <-
function(x) {
length(endpoints(x,on='weeks'))-1
}
#' @rdname ndays
`nmonths` <-
function(x) {
length(endpoints(x,on='months'))-1
}
#' @rdname ndays
`nquarters` <-
function(x) {
length(endpoints(x,on='quarters'))-1
}
#' @rdname ndays
`nyears` <-
function(x) {
length(endpoints(x,on='years'))-1
}
xts/R/matrix.R 0000644 0001762 0000144 00000004745 14654242576 012751 0 ustar ligges users #
# 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 2 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 .
# functions for matrix <--> xts conversions
`as.matrix.xts` <-
function(x, ...) {
# This function follows the pattern of as.matrix.zoo()
cd <- coredata(x)
y <- as.matrix(cd, ...)
if (length(cd) == 0) {
dim(y) <- c(0, 0)
}
# colnames
if (length(y) > 0) {
cnx <- colnames(x)
if (length(cnx) > 0) {
colnames(y) <- cnx
} else {
cn <- deparse(substitute(x), width.cutoff = 100, nlines = 1)
if (NCOL(x) == 1) {
colnames(y) <- cn
} else {
colnames(y) <- paste(cn, 1:ncol(x), sep = ".")
}
}
} else if (nrow(y) != length(.index(x))) {
dim(y) <- c(length(.index(x)), 0)
}
# rownames
if (!is.null(y) && nrow(y) > 0 && is.null(rownames(y))) {
rownames(y) <- as.character(index(x))
}
y
}
`re.matrix` <-
function(x,...) {
as.matrix(x,...)
}
#' @rdname as.xts
`as.xts.matrix` <-
function(x,order.by,dateFormat="POSIXct",frequency=NULL,...,.RECLASS=FALSE) {
# Should allow 'order.by' to be a vector of dates or a scaler
# representing the column number to use.
if(missing(order.by)) {
# The 'index' of zoo objects is set to 'rownames' when converted with 'as.matrix',
# but it is of class 'Date', not 'POSIXct'... - jmu
if(is.null(rownames(x)))
stop("order.by must be either 'rownames()' or otherwise specified")
else
# added '...' args to allow for tz specification
order.by <- do.call(paste('as',dateFormat,sep='.'),list(rownames(x)))
}
if(.RECLASS) {
xx <- xts(x,
order.by=order.by,
frequency=frequency,
.CLASS='matrix',
...)
} else {
xx <- xts(x,
order.by=order.by,
frequency=frequency,
...)
}
xx
}
xts/R/last.R 0000644 0001762 0000144 00000011710 14654242576 012376 0 ustar ligges users #
# 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 2 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 .
#' @rdname first
`last` <-
function(x,...)
{
UseMethod("last")
}
#' @rdname first
`last.default` <-
function(x,n=1,keep=FALSE,...)
{
if(length(x) == 0)
return(x)
if(is.character(n)) {
xx <- try.xts(x, error=FALSE)
if(is.xts(xx)) {
xx <- last.xts(x, n=n, keep=keep, ...)
return(reclass(xx))
}
}
if(is.null(dim(x))) {
if(n > 0) {
sub <- seq.int(to = length(x), length.out = min(n, length(x)))
xx <- x[sub]
if(keep) xx <- structure(xx,keep=x[1:(NROW(x)+(-n))])
xx
} else if(n < 0) {
sub <- seq_len(max(length(x) + n, 0L))
xx <- x[sub]
if(keep) xx <- structure(xx,keep=x[((NROW(x)-(-n)+1):NROW(x))])
xx
} else {
xx <- x[0]
if(keep) xx <- structure(xx,keep=x[0])
xx
}
} else {
if(n > 0) {
sub <- seq.int(to = NROW(x), length.out = min(n, NROW(x)))
xx <- x[sub,,drop=FALSE]
if(keep) xx <- structure(xx,keep=x[1:(NROW(x)+(-n)),])
xx
} else if(n < 0) {
sub <- seq_len(max(NROW(x) + n, 0L))
xx <- x[sub,,drop=FALSE]
if(keep) xx <- structure(xx,keep=x[((NROW(x)-(-n)+1):NROW(x)),])
xx
} else {
xx <- x[0,,drop=FALSE]
if(keep) xx <- structure(xx,keep=x[0,])
xx
}
}
}
#' @rdname first
`last.xts` <-
function(x,n=1,keep=FALSE,...)
{
if(length(x) == 0)
return(x)
if(is.character(n)) {
# n period set
np <- strsplit(n," ",fixed=TRUE)[[1]]
if(length(np) > 2 || length(np) < 1)
stop(paste("incorrectly specified",sQuote("n"),sep=" "))
# series periodicity
sp <- periodicity(x)
sp.units <- sp[["units"]]
# requested periodicity$units
rpu <- np[length(np)]
rpf <- ifelse(length(np) > 1, as.numeric(np[1]), 1)
if(rpu == sp.units) {
n <- rpf
} else {
# if singular - add an s to make it work
if(substr(rpu,length(strsplit(rpu,'')[[1]]),length(strsplit(rpu,'')[[1]])) != 's')
rpu <- paste(rpu,'s',sep='')
u.list <- list(secs=4,seconds=4,mins=3,minutes=3,hours=2,days=1,
weeks=1,months=1,quarters=1,years=1)
dt.options <- c('seconds','secs','minutes','mins','hours','days',
'weeks','months','quarters','years')
if(!rpu %in% dt.options)
stop(paste("n must be numeric or use",paste(dt.options,collapse=',')))
dt <- dt.options[pmatch(rpu,dt.options)]
if(u.list[[dt]] > u.list[[sp.units]]) {
# req is for higher freq data period e.g. 100 mins of daily data
stop(paste("At present, without some sort of magic, it isn't possible",
"to resolve",rpu,"from",sp$scale,"data"))
}
ep <- endpoints(x,dt)
if(rpf > length(ep)-1) {
rpf <- length(ep)-1
warning("requested length is greater than original")
}
if(rpf > 0) {
n <- ep[length(ep)-rpf]+1
if(is.null(dim(x))) {
xx <- x[n:NROW(x)]
} else {
xx <- x[n:NROW(x),,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[1:(ep[length(ep)+(-rpf)])])
return(xx)
} else if(rpf < 0) {
n <- ep[length(ep)+rpf]
if(is.null(dim(x))) {
xx <- x[1:n]
} else {
xx <- x[1:n,,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[(ep[length(ep)-(-rpf)]+1):NROW(x)])
return(xx)
} else {
if(is.null(dim(x))) {
xx <- x[0]
} else {
xx <- x[0,,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[0])
return(xx)
}
}
}
if(length(n) != 1) stop("n must be of length 1")
if(n > 0) {
n <- min(n, NROW(x))
if(is.null(dim(x))) {
xx <- x[(NROW(x)-n+1):NROW(x)]
} else {
xx <- x[(NROW(x)-n+1):NROW(x),,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[1:(NROW(x)+(-n))])
xx
} else if(n < 0) {
if(abs(n) >= NROW(x))
return(x[0])
if(is.null(dim(x))) {
xx <- x[1:(NROW(x)+n)]
} else {
xx <- x[1:(NROW(x)+n),,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[((NROW(x)-(-n)+1):NROW(x))])
xx
} else {
if(is.null(dim(x))) {
xx <- x[0]
} else {
xx <- x[0,,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[0])
xx
}
}
xts/R/zoo.R 0000644 0001762 0000144 00000003314 14654242576 012243 0 ustar ligges users #
# 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 2 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 .
# functions to handle zoo <--> xts conversions
`re.zoo` <-
function(x,...) {
xx <- coredata(x)
xx <- zoo(xx,
order.by=index(x),
...)
if(length(dimnames(x)[[2]]) < 2) {
dimnames(xx) <- NULL
dim(xx) <- NULL
attr(xx,'names') <- as.character(index(x))
}
xx
}
#' @rdname as.xts
`as.xts.zoo` <-
function(x,order.by=index(x),frequency=NULL,...,.RECLASS=FALSE) {
if(.RECLASS) {
xx <- xts(coredata(x), # Cannot use 'zoo()' on objects of class 'zoo' - jmu
order.by=order.by,
frequency=frequency,
.CLASS='zoo',
...)
} else {
xx <- xts(coredata(x), # Cannot use 'zoo()' on objects of class 'zoo' - jmu
order.by=order.by,
frequency=frequency,
...)
}
xx
}
`as.zoo.xts` <-
function(x,...) {
cd <- coredata(x);
if( length(cd)==0 )
cd <- NULL
zoo(cd,
order.by=index(x),
...)
}
xts/R/timeBasedRange.R 0000644 0001762 0000144 00000002165 14654242576 014311 0 ustar ligges users #
# 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 2 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 .
#' @rdname timeBasedSeq
`timeBasedRange` <-
function(x, ...) {
# convert unquoted time range to
if (!is.character(x))
x <- deparse(match.call()$x)
# determine start and end points
tblist <- timeBasedSeq(x,NULL)
# if(!is.null(tblist$length.out))
# return(tblist$from)
c(as.numeric(tblist$from), as.numeric(tblist$to))
}
xts/R/coredata.xts.R 0000644 0001762 0000144 00000015175 14654242576 014043 0 ustar ligges users #
# 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 2 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 .
#' Extract/Replace Core Data of an xts Object
#'
#' Mechanism to extract and replace the core data of an xts object.
#'
#' Extract coredata of an xts object - removing all attributes except
#' `dim` and `dimnames` and returning a matrix object with rownames
#' converted from the index of the xts object.
#'
#' The rownames of the result use the format specified by `tformat(x)` when
#' `fmt = TRUE`. When `fmt` is a character string to be passed to `format()`.
#' See [`strptime()`] for valid format strings. Setting `fmt = FALSE` will
#' return the row names by simply coercing the index class to a character
#' string in the default manner.
#'
#' `xcoredata()` is the complement to `coredata()`. It returns all of the
#' attributes normally removed by `coredata()`. Its purpose, along with the
#' the replacement function `xcoredata<-` is primarily for developers using
#' \pkg{xts}' [`try.xts()`] and [`reclass()`] functionality inside functions
#' so the functions can take any time series class as an input and return the
#' same time series class.
#'
#' @param x An xts object.
#' @param fmt Should the rownames be formated using `tformat()`? Alternatively
#' a date/time string to be passed to `format()`. See details.
#' @param value Non-core attributes to assign.
#' @param \dots Unused.
#'
#' @return Returns either a matrix object for coredata, or a list of named
#' attributes.
#'
#' The replacement functions are called for their side-effects.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`coredata()`][zoo::zoo], [`xtsAttributes()`]
#'
#' @keywords utilities
#' @examples
#'
#' data(sample_matrix)
#' x <- as.xts(sample_matrix, myattr=100)
#' coredata(x)
#' xcoredata(x)
#'
coredata.xts <- function(x, fmt=FALSE, ...) {
x.attr <- attributes(x)
if(is.character(fmt)) {
tformat(x) <- fmt
fmt <- TRUE
}
if(length(x) > 0 && fmt) {
if(!is.null(tformat(x))) {
x.attr$dimnames <- list(format(index(x), format=tformat(x)),
dimnames(x)[[2]])
tformat(x) <- NULL # remove before printing
} else {
x.attr$dimnames <- list(format(index(x)),dimnames(x)[[2]])
}
#attributes not to be kept
original.attr <- x.attr[!names(x.attr) %in%
c('dim','dimnames')]
if(is.null(dim(x))) {
xx <- structure(coredata(x), names=x.attr$dimnames[[1]])
} else {
xx <- structure(coredata(x), dim=dim(x), dimnames=x.attr$dimnames)
}
for(i in names(original.attr)) {
attr(xx,i) <- NULL
}
return(xx)
}
if(length(x) == 0) {
xx <- NextMethod(x)
attr(xx, ".indexCLASS") <- NULL
attr(xx, "tclass") <- NULL
# Remove tz attrs (object created before 0.10-3)
attr(xx, ".indexTZ") <- NULL
attr(xx, "tzone") <- NULL
return(xx)
} else
return(.Call(C_coredata_xts, x))
}
`xcoredata.default` <-
function(x,...) {
x.attr <- attributes(x)
original.attr <- x.attr[!names(x.attr) %in%
c('dim','dimnames')]
original.attr
}
#' @rdname coredata.xts
`xcoredata` <-
function(x,...) {
UseMethod('xcoredata')
}
#' @rdname coredata.xts
`xcoredata<-` <- function(x,value) {
UseMethod('xcoredata<-')
}
`xcoredata<-.default` <- function(x,value) {
if(is.null(value)) {
return(coredata(x))
} else {
for(att in names(value)) {
if(!att %in% c('dim','dimnames'))
attr(x,att) <- value[[att]]
}
return(x)
}
}
#' Extract and Replace xts Attributes
#'
#' Extract and replace non-core xts attributes.
#'
#' This function allows users to assign custom attributes to the xts objects,
#' without altering core xts attributes (i.e. tclass, tzone, and tformat).
#'
#' [`attributes()`] returns all attributes, including core attributes of the
#' xts class.
#'
#' @param x An xts object.
#' @param user Should user-defined attributes be returned? The default of
#' `NULL` returns all xts attributes.
#' @param value A list of new `name = value` attributes.
#'
#' @return A named list of user-defined attributes.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`attributes()`]
#'
#' @keywords utilities
#' @examples
#'
#' x <- xts(matrix(1:(9*6),nc=6),
#' order.by=as.Date(13000,origin="1970-01-01")+1:9,
#' a1='my attribute')
#'
#' xtsAttributes(x)
#' xtsAttributes(x) <- list(a2=2020)
#'
#' xtsAttributes(x)
#' xtsAttributes(x) <- list(a1=NULL)
#' xtsAttributes(x)
#'
`xtsAttributes` <-
function(x, user=NULL) {
# get all additional attributes not standard to xts object
#stopifnot(is.xts(x))
rm.attr <- c('dim','dimnames','index','class','names')
x.attr <- attributes(x)
if(is.null(user)) {
# Both xts and user attributes
rm.attr <- c(rm.attr,'.CLASS','.CLASSnames','.ROWNAMES', '.indexCLASS', '.indexFORMAT', '.indexTZ', 'tzone', 'tclass')
xa <- x.attr[!names(x.attr) %in% rm.attr]
}
else
if(user) {
# Only user attributes
rm.attr <- c(rm.attr,'.CLASS','.CLASSnames','.ROWNAMES', '.indexCLASS', '.indexFORMAT','.indexTZ','tzone','tclass',
x.attr$.CLASSnames)
xa <- x.attr[!names(x.attr) %in% rm.attr]
} else {
# Only xts attributes
xa <- x.attr[names(x.attr) %in% x.attr$.CLASSnames]
}
if(length(xa) == 0) return(NULL)
xa
}
#' @rdname xtsAttributes
`xtsAttributes<-` <-
function(x,value) {
UseMethod('xtsAttributes<-')
}
`xtsAttributes<-.xts` <-
function(x,value) {
if(is.null(value)) {
for(nm in names(xtsAttributes(x))) {
attr(x,nm) <- NULL
}
} else
for(nv in names(value)) {
if(!nv %in% c('dim','dimnames','index','class','.CLASS','.ROWNAMES','.CLASSnames'))
attr(x,nv) <- value[[nv]]
}
# Remove tz attrs (object created before 0.10-3)
attr(x, ".indexTZ") <- NULL
attr(x, "tzone") <- NULL
# Remove index class attrs (object created before 0.10-3)
attr(x, ".indexCLASS") <- NULL
attr(x, "tclass") <- NULL
# Remove index format attr (object created before 0.10-3)
attr(x, ".indexFORMAT") <- NULL
x
}
xts/R/parse8601.R 0000644 0001762 0000144 00000021312 14654242576 013063 0 ustar ligges users #
# 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 2 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 .
# This function corresponds to the ISO 8601 standard
# for specifying dates and times as described in
# the ISO 8601:2004e standard.
#
# See:
# http://en.wikipedia.org/wiki/ISO_8601
# http://www.iso.org/iso/support/faqs/faqs_widely_used_standards/widely_used_standards_other/date_and_time_format.htm
#
# This implementation is currently restricted
# to interval based parsing, with basic or
# extended formats, and duration strings.
# Currently the duration must be in basic format
# e.g. PnnYnnMnnDTnnHnnMnnS
#
# The return value is a list of start and
# end times, in POSIXt space.
#
# Copyright 2009. Jeffrey A. Ryan. All rights reserved.
# This is licensed under the GPL version 2 or later
#
#' Create an ISO8601 string from a time series object
#'
#' This function uses the `start()` and `end()` of a time series object to
#' create an ISO8601 string that spans the time range of the object.
#'
#' This is not exported an therefore not part of the official xts API.
#'
#' @param x A time series object with `start()` and `end()` methods.
#'
#' @return A character vector of length one describing the ISO-style format
#' for the range of a given time series object.
#'
#' @noRd
#' @examples
#'
#' data(sample_matrix)
#' x <- as.xts(sample_matrix)
#' .makeISO8601(x)
#'
.makeISO8601 <- function(x) {
paste(start(x), end(x), sep = "/")
}
#' Internal ISO 8601:2004(e) Time Parser
#'
#' This function replicates most of the ISO standard for parsing times and
#' time-based ranges in a universally accepted way. The best documentation is
#' the official ISO page as well as the Wikipedia entry for ISO 8601:2004.
#'
#' The basic idea is to create the endpoints of a range, given a string
#' representation. These endpoints are aligned in POSIXct time to the zero
#' second of the day at the beginning, and the 59.9999th second of the 59th
#' minute of the 23rd hour of the final day.
#'
#' For dates prior to the epoch (1970-01-01) the ending time is aligned to the
#' 59.0000 second. This is due to a bug/feature in the \R implementation of
#' `as.POSIXct()` and `mktime0()` at the C-source level. This limits the
#' precision of ranges prior to 1970 to 1 minute granularity with the current
#' \pkg{xts} workaround.
#'
#' Recurring times over multiple days may be specified using the "T" notation.
#' See the examples for details.
#'
#' @param x A character string conforming to the ISO 8601:2004(e) rules.
#' @param start Lower constraint on range.
#' @param end Upper constraint of range
#' @param tz Timezone (tzone) to use internally.
#'
#' @return A two element list with an entry named \sQuote{first.time} and
#' one named \sQuote{last.time}.
#'
#' @note There is no checking done to test for a properly constructed ISO
#' format string. This must be correctly entered by the user.
#'
#' When using durations, it is important to note that the time of the duration
#' specified is not necessarily the same as the realized periods that may be
#' returned when applied to an irregular time series. This is not a bug, it is
#' a standards and implementation gotcha.
#'
#' @author Jeffrey A. Ryan
#'
#' @references \cr
#'
#'
#' @aliases ISO8601 parseISO8601
#' @rdname parseISO8601
#'
#' @keywords utilities
#' @examples
#'
#' # the start and end of 2000
#' .parseISO8601('2000')
#'
#' # the start of 2000 and end of 2001
#' .parseISO8601('2000/2001')
#'
#' # May 1, 2000 to Dec 31, 2001
#' .parseISO8601('2000-05/2001')
#'
#' # May 1, 2000 to end of Feb 2001
#' .parseISO8601('2000-05/2001-02')
#'
#' # Jan 1, 2000 to Feb 29, 2000; note the truncated time on the LHS
#' .parseISO8601('2000-01/02')
#'
#' # 8:30 to 15:00 (used in xts subsetting to extract recurring times)
#' .parseISO8601('T08:30/T15:00')
#'
.parseISO8601 <- function(x, start, end, tz="") {
# x: character vector of length 1 in ISO8601:2004(e) format
# start: optional earliest time
# end: optional latest time
# tz: optional tzone to create with
as_numeric <- function(.x) {
# simple helper function
if(gsub(" ","",.x)=="")
NULL
else as.numeric(.x)
}
x <- gsub("NOW",format(Sys.time(),"%Y%m%dT%H%M%S"),x)
x <- gsub("TODAY",format(Sys.Date(),"%Y%m%d"),x)
if(identical(grep("/|(--)|(::)", x), integer(0))) {
x <- paste(x,x,sep="/")
}
intervals <- unlist(strsplit(x, "/|(--)|(::)"))
# e.g. "/2009": "" "xxx" end of defined, needs context
# e.g. "2009/": "xxx" start of defined, needs context
# check for duration specification
DURATION <- ""
if(length(intervals)==2L) {
if(substr(intervals[1],0,1)=="P") {
# duration on LHS
DURATION <- intervals[1]
DURATION_LHS <- TRUE
intervals[1] <- ""
}
if(substr(intervals[2],0,1)=="P") {
# duration on RHS
DURATION <- intervals[2]
DURATION_LHS <- FALSE
intervals <- intervals[1]
}
# leave alone if no duration
}
parse.side <- function(x, startof) {
if( is.na(x) || !nzchar(x))
return(c(NULL))
basic <- gsub(":|-", "", x, perl=TRUE) #, extended=TRUE)
date.time <- unlist(strsplit(basic, " |T"))
# dates
date <- date.time[1]
if(!missing(startof) && nchar(basic)==2L) {
startof <- gsub(":|-", "", startof, perl=TRUE) #, extended=TRUE)
if(nchar(startof) - nchar(date) >= 4) {
# FIXME 200901/2009 needs to work, fix is ex-post now
# pad to last place of startof
# with startof values
sstartof <- substr(startof,0,nchar(startof)-nchar(date))
date <- paste(sstartof,date,sep="")
}
}
date <- sprintf("%-8s", date)
YYYY <- substr(date,0,4)
MM <- substr(date,5,6)
DD <- substr(date,7,8)
# times
time <- date.time[2]
if( !is.na(time)) {
time <- sprintf("%-6s", time)
H <- substr(time,0,2)
M <- substr(time,3,4)
S <- substr(time,5,10000L)
} else H<-M<-S<-""
# return as list
c(as.list(c(
year=as_numeric(YYYY),
month=as_numeric(MM),
day=as_numeric(DD),
hour=as_numeric(H),
min=as_numeric(M),
sec=as_numeric(S)
)
),tz=tz)
}
s <- e <- NA
if(nzchar(intervals[1])) # LHS
s <- as.POSIXlt(do.call(firstof, parse.side(intervals[1])))
if(length(intervals) == 2L) { # RHS
e <- as.POSIXlt(do.call(lastof, parse.side(intervals[2],intervals[1])))
if(is.na(e))
e <- as.POSIXlt(do.call(lastof, parse.side(intervals[2])))
}
if(is.na(s) && is.na(e) && !nzchar(DURATION) && intervals[1L] != "") {
warning("cannot determine first and last time from ", x)
return(list(first.time=NA_real_,last.time=NA_real_))
}
if(!missing(start)) {
start <- as.numeric(start)
#s <- as.POSIXlt(structure(max(start, as.numeric(s), na.rm=TRUE),
# class=c("POSIXct","POSIXt"),tz=tz))
s <- as.POSIXlt(.POSIXct(max(start, as.numeric(s), na.rm=TRUE),tz=tz))
}
if(!missing(end)) {
end <- as.numeric(end)
#e <- as.POSIXlt(structure(min(end, as.numeric(e), na.rm=TRUE),
# class=c("POSIXct","POSIXt"),tz=tz))
e <- as.POSIXlt(.POSIXct(min(end, as.numeric(e), na.rm=TRUE),tz=tz))
}
if(nzchar(DURATION)) {
parse_duration <- function(P) {
# TODO:
# strip leading P from string
# convert second M (min) to 'm' IFF following a T
# remove/ignore T
# convert extended format (PYYYYMMDD) to basic format (PnnYnnMnnD)
P <- gsub("P","",P)
P <- gsub("T(.*)M","\\1m",P)
n <- unlist(strsplit(P, "[[:alpha:]]"))
d <- unlist(strsplit(gsub("[[:digit:]]", "", P),""))
dur.vec <- list(as.numeric(n),unname(c(Y=6,M=5,D=4,H=3,m=2,S=1)[d]))
init.vec <- rep(0, 9)
init.vec[dur.vec[[2]]] <- dur.vec[[1]]
init.vec
}
if(DURATION_LHS) {
s <- as.POSIXct(structure(as.list(mapply(`-`,e,parse_duration(DURATION))),
class=c("POSIXlt","POSIXt"), tzone=attr(e,"tzone")))
} else {
e <- as.POSIXct(structure(as.list(mapply(`+`,s,parse_duration(DURATION))),
class=c("POSIXlt","POSIXt"), tzone=attr(e,"tzone")))
}
}
list(first.time=as.POSIXct(s),last.time=as.POSIXct(e))
}
xts/R/zzz.R 0000644 0001762 0000144 00000007536 14654242576 012303 0 ustar ligges users #
# 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 2 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 .
# internal package environment for use with lines.xts
# Do we still need this env?
.xtsEnv <- new.env()
# Environment for our xts chart objects (xts_chob)
.plotxtsEnv <- new.env()
register_s3_method <-
function(pkg, generic, class, fun = NULL)
{
stopifnot(is.character(pkg), length(pkg) == 1L)
stopifnot(is.character(generic), length(generic) == 1L)
stopifnot(is.character(class), length(class) == 1L)
if (is.null(fun)) {
fun <- get(paste0(generic, ".", class), envir = parent.frame())
} else {
stopifnot(is.function(fun))
}
if (isNamespaceLoaded(pkg)) {
registerS3method(generic, class, fun, envir = asNamespace(pkg))
}
# Always register hook in case package is later unloaded & reloaded
setHook(
packageEvent(pkg, "onLoad"),
function(...) {
registerS3method(generic, class, fun, envir = asNamespace(pkg))
}
)
}
.onAttach <- function(libname, pkgname)
{
warn_dplyr_lag <- getOption("xts.warn_dplyr_breaks_lag", TRUE)
dplyr_will_mask_lag <- conflictRules("dplyr")
if (is.null(dplyr_will_mask_lag)) {
dplyr_will_mask_lag <- TRUE
} else {
dplyr_will_mask_lag <- all(dplyr_will_mask_lag$exclude != "lag")
}
if (warn_dplyr_lag && dplyr_will_mask_lag) {
ugly_message <- "
######################### Warning from 'xts' package ##########################
# #
# The dplyr lag() function breaks how base R's lag() function is supposed to #
# work, which breaks lag(my_xts). Calls to lag(my_xts) that you type or #
# source() into this session won't work correctly. #
# #
# Use stats::lag() to make sure you're not using dplyr::lag(), or you can add #
# conflictRules('dplyr', exclude = 'lag') to your .Rprofile to stop #
# dplyr from breaking base R's lag() function. #
# #
# Code in packages is not affected. It's protected by R's namespace mechanism #
# Set `options(xts.warn_dplyr_breaks_lag = FALSE)` to suppress this warning. #
# #
###############################################################################"
if ("package:dplyr" %in% search()) {
packageStartupMessage(ugly_message)
} else {
setHook(packageEvent("dplyr", "attach"),
function(...) packageStartupMessage(ugly_message))
}
}
}
.onLoad <- function(libname, pkgname)
{
if (getRversion() < "3.6.0") {
register_s3_method("timeSeries", "as.timeSeries", "xts")
if (utils::packageVersion("zoo") < "1.8.5") {
# xts:::as.zoo.xts was copied to zoo:::as.zoo.xts in zoo 1.8-5
register_s3_method("zoo", "as.zoo", "xts")
}
}
invisible()
}
.onUnload <- function(libpath) {
library.dynam.unload("xts", libpath)
}
if(getRversion() < "2.11.0") {
.POSIXct <- function(xx, tz = NULL)
structure(xx, class = c("POSIXct", "POSIXt"), tzone = tz)
}
xts/R/xts-package.R 0000644 0001762 0000144 00000014305 14654242576 013645 0 ustar ligges users #
# 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 2 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 .
#' Sample Data Matrix For xts Example and Unit Testing
#'
#' Simulated 180 observations on 4 variables.
#'
#' @usage data(sample_matrix)
#'
#' @format \preformatted{The format is:
#' num [1:180, 1:4] 50.0 50.2 50.4 50.4 50.2 ...
#' - attr(*, "dimnames")=List of 2
#' ..$ : chr [1:180] "2007-01-02" "2007-01-03" "2007-01-04" "2007-01-05" ...
#' ..$ : chr [1:4] "Open" "High" "Low" "Close" }
#'
#' @rdname sample.data
#' @keywords datasets
#' @examples
#'
#' data(sample_matrix)
#'
"sample_matrix"
#' Internal Documentation
#'
#' This help file is to help in development of xts, as well as provide some
#' clarity and insight into its purpose and implementation.
#'
#' Last modified: 2008-08-06 by Jeffrey A. Ryan Version: 0.5-0 and above
#'
#' The \pkg{xts} package xts designed as a drop-in replacement for the very
#' popular \pkg{zoo} package. Most all functionality of zoo has been extended
#' or carries into the xts package.
#'
#' Notable changes in direction include the use of time-based indexing, at
#' first explicitely, now implicitely.
#'
#' An xts object consists of data in the form of a matrix, an index -
#' ordered and increasing, either numeric or integer, and additional attributes
#' for use internally, or for end-user purposes.
#'
#' The current implementation enforces two major rules on the object. One is
#' that the index must be coercible to numeric, by way of `as.POSIXct`.
#' There are defined types that meet this criteria. See `timeBased` for
#' details.
#'
#' The second requirement is that the object cannot have rownames. The
#' motivation from this comes in part from the work Matthew Doyle has done in
#' his data.table class, in the package of the same name. Rownames in must be
#' character vectors, and as such are inefficient in both storage and
#' conversion. By eliminating the rownames, and providing a numeric index of
#' internal type `REAL` or `INTEGER`, it is possible to maintain a
#' connection to standard date and time classes via the POSIXct functions,
#' while at at the same time maximizing efficiencies in data handling.
#'
#' User level functions `index`, as well as conversion to other classes
#' proceeds as if there were rownames. The code for `index` automatically
#' converts time to numeric in both extraction and replacement functionality.
#' This provides a level of abstraction to facilitate internal, and external
#' package use and inter-operability.
#'
#' There is also new work on providing a C-level API to some of the xts
#' functionality to facilitate external package developers to utilize the fast
#' utility routines such as subsetting and merges, without having to call only
#' from . Obviously this places far more burden on the developer to not only
#' understand the internal xts implementation, but also to understand all of
#' what is documented for R-internals (and much that isn't). At present the
#' functions and macros available can be found in the \sQuote{xts.h} file in
#' the src directory.
#'
#' There is no current documentation for this API. The adventure starts here.
#' Future documentation is planned, not implemented.
#'
#' @name xts-internals
#' @author Jeffrey A. Ryan
#' @keywords utilities
NULL
#' xts: extensible time-series
#'
#' Extensible time series class and methods, extending and behaving like zoo.
#'
#' Easily convert one of \R's many time-series (and non-time-series) classes to a
#' true time-based object which inherits all of zoo's methods, while allowing
#' for new time-based tools where appropriate.
#'
#' Additionally, one may use \pkg{xts} to create new objects which can contain
#' arbitrary attributes named during creation as name=value pairs.
#'
#' @name xts-package
#' @author Jeffrey A. Ryan and Joshua M. Ulrich
#'
#' Maintainer: Joshua M. Ulrich
#' @seealso [`xts()`], [`as.xts()`], [`reclass()`], [`zoo()`][zoo::zoo]
#' @keywords package
"_PACKAGE"
#' xts C API Documentation
#'
#' This help file is to help in development of xts, as well as provide some
#' clarity and insight into its purpose and implementation.
#'
#' By Jeffrey A. Ryan, Dirk Eddelbuettel, and Joshua M. Ulrich Last modified:
#' 2018-05-02 Version: 0.10-3 and above
#'
#' At present the \pkg{xts} API has publicly available interfaces to the
#' following functions (as defined in `xtsAPI.h`):
#'
#' \preformatted{Callable from other R packages:
#' SEXP xtsIsOrdered(SEXP x, SEXP increasing, SEXP strictly)
#' SEXP xtsNaCheck(SEXP x, SEXP check)
#' SEXP xtsTry(SEXP x)
#' SEXP xtsRbind(SEXP x, SEXP y, SEXP dup)
#' SEXP xtsCoredata(SEXP x)
#' SEXP xtsLag(SEXP x, SEXP k, SEXP pad)
#'
#' Internal use functions:
#' SEXP isXts(SEXP x)
#' void copy_xtsAttributes(SEXP x, SEXP y)
#' void copy_xtsCoreAttributes(SEXP x, SEXP y)
#'
#' Internal use macros:
#' xts_ATTRIB(x)
#' xts_COREATTRIB(x)
#' GET_xtsIndex(x)
#' SET_xtsIndex(x,value)
#' GET_xtsIndexFormat(x)
#' SET_xtsIndexFormat(x,value)
#' GET_xtsCLASS(x)
#' SET_xtsCLASS(x,value)
#'
#' Internal use SYMBOLS:
#' xts_IndexSymbol
#' xts_ClassSymbol
#' xts_IndexFormatSymbol
#'
#' Callable from R:
#' SEXP mergeXts(SEXP args)
#' SEXP rbindXts(SEXP args)
#' SEXP tryXts(SEXP x)
#' }
#'
#' @name xtsAPI
#' @author Jeffrey A. Ryan
#' @keywords utilities
#' @examples
#'
#' \dontrun{
#' # some example code to look at
#'
#' file.show(system.file('api_example/README', package="xts"))
#' file.show(system.file('api_example/src/checkOrder.c', package="xts"))
#' }
#'
NULL
xts/R/periodicity.R 0000644 0001762 0000144 00000013073 14654242576 013763 0 ustar ligges users #
# 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 2 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 .
time_frequency <- function(x) {
x <- gsub(":|/|-| ", "", x)
nc <- nchar(x)
if(nc < 4) stop("unrecognizable time.scale")
if(nc == 4) res <- 2678400 * 12 #"yearly"
if(nc > 4) res <- 2678400 #"monthly"
if(nc > 6) res <- 86400 #"daily"
if(nc > 8) res <- 3600 #"hourly"
if(nc > 10) res <- 60 #"minute"
if(nc > 12) res <- 1 #"seconds"
return(res)
}
#' Approximate Series Periodicity
#'
#' Estimate the periodicity of a time-series-like object by calculating the
#' median time between observations in days.
#'
#' A simple wrapper to quickly estimate the periodicity of a given data.
#' Returning an object of type `periodicity`.
#'
#' This calculates the median time difference between observations as a
#' difftime object, the numerical difference, the units of measurement, and the
#' derived scale of the data as a string.
#'
#' The time index currently must be of either a 'Date' or 'POSIXct' class, or
#' or coercible to one of them.
#'
#' The 'scale' component of the result is an estimate of the periodicity of the
#' data in common terms - e.g. 7 day daily data is best described as 'weekly',
#' and would be returned as such.
#'
#' @param x A time-series-like object.
#' @param \dots Unused.
#'
#' @return A 'periodicity' object with the following elements:
#' * the `difftime` object,
#' * frequency: the median time difference between observations
#' * start: the first observation
#' * end: the last observation
#' * units: one of secs, mins, hours, or days
#' * scale: one of seconds, minute, hourly, daily, weekly, monthly, quarterly, or yearly
#' * label: one of second, minute, hour, day, week, month, quarter, year
#'
#' Possible `scale` values are: \sQuote{minute}, \sQuote{hourly}, \sQuote{daily},
#' \sQuote{weekly}, \sQuote{monthly}, \sQuote{quarterly}, and \sQuote{yearly}.
#'
#' @note This function only attempts to be a *good estimate* for the underlying
#' periodicity. If the series is too short, or has highly irregular periodicity,
#' the return values will not be accurate. That said, it is quite robust and
#' used internally within \pkg{xts}.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`difftime()`]
#'
#' @keywords utilities
#' @examples
#'
#' zoo.ts <- zoo(rnorm(231),as.Date(13514:13744,origin="1970-01-01"))
#' periodicity(zoo.ts)
#'
periodicity <- function(x, ...) {
if( timeBased(x) ) {
if( anyNA(x) ) {
warning("removing NA in 'x' to calculate periodicity")
x <- x[!is.na(x)]
}
x <- try.xts(x, error = "cannot convert 'x' to xts")
}
if (!is.xts(x)) {
x <- try.xts(x, error = "cannot convert 'x' to xts")
}
n <- length(.index(x))
if( n < 2 ) {
res <- list(difftime = structure(0, units='secs', class='difftime'),
frequency = 0,
start = NA,
end = NA,
units = 'secs',
scale = 'seconds',
label = 'second')
res <- structure(res, class='periodicity')
if( n == 0 ) {
warning("can not calculate periodicity of empty object")
} else {
warning("can not calculate periodicity of 1 observation")
res$start <- start(x)
res$end <- end(x)
}
return(res)
}
p <- median(diff( .index(x) ))
# Date and POSIXct
if(p < 60) {
units <- "secs"
scale <- "seconds"
label <- "second"
} else
if(p < 3600) {
units <- "mins"
scale <- "minute"
label <- "minute"
p <- p/60L
} else
if(p < 86400) {
# < 1 day
units <- "hours"
scale <- "hourly"
label <- "hour"
} else
if(p == 86400) {
units <- "days"
scale <- "daily"
label <- "day"
} else
if(p <= 604800) {
# 86400 * 7
units <- "days"
scale <- "weekly"
label <- "week"
} else
if(p <= 2678400) {
# 86400 * 31
units <- "days"
scale <- "monthly"
label <- "month"
} else
if(p <= 7948800) {
# 86400 * 92
units <- "days"
scale <- "quarterly"
label <- "quarter"
} else {
# years
units <- "days"
scale <- "yearly"
label <- "year"
}
structure(list(difftime = as.difftime(p, units = units),
frequency = p,
start = start(x),
end = end(x),
units = units,
scale = scale,
label = label),
class = 'periodicity')
}
`print.periodicity` <-
function (x, ...)
{
x.freq <- ifelse(x$scale %in% c("minute", "seconds"), x$frequency,
"")
if (x.freq == "") {
cap.scale <- paste(toupper(substring(x$scale, 1, 1)),
substring(x$scale, 2), sep = "")
cat(paste(cap.scale, "periodicity from", x$start, "to",
x$end, "\n", sep = " "))
}
else {
cat(paste(x.freq, x$scale, "periodicity from", x$start,
"to", x$end, "\n", sep = " "))
}
}
xts/R/rollapply.xts.R 0000644 0001762 0000144 00000013605 14654242576 014273 0 ustar ligges users #
# 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 2 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 .
rollapply.xts <- function(data, width, FUN, ..., by=1, by.column=TRUE,
fill=if(na.pad) NA, na.pad=TRUE, partial=TRUE,
align=c("right","center","left")) {
if (!missing(na.pad)) {
warning("na.pad argument is deprecated")
}
if (!missing(partial)) {
warning("partial argument is not currently supported")
}
data <- try.xts(data) # jmu: is this necessary?
# Code taken/adapted from rollapply.zoo from the 'zoo' package
# xts doesn't currently have these functions
# if(by.column && by == 1 && ascending && length(list(...)) < 1)
# switch(deparse(substitute(FUN)),
# mean = return(rollmean(data, width, na.pad = na.pad, align = align)),
# max = return(rollmax(data, width, na.pad = na.pad, align = align)),
# median = return(rollmedian(data, width, na.pad = na.pad, align = align)))
nr <- NROW(data)
nc <- NCOL(data)
width <- as.integer(width)[1]
stopifnot( width > 0, width <= nr )
## process alignment
align <- match.arg(align)
n1 <- switch(align,
"left" = { width - 1},
"center" = { floor(width/2) },
"right" = { 0 })
idx <- index(data)
tt <- index(data)[seq((width-n1), (nr-n1), by)]
#tt <- idx[seq((width-n1), (nr-n1), 1)]
## evaluate FUN only on coredata(data)
#data <- coredata(data)
FUN <- match.fun(FUN)
ind <- as.matrix(seq.int(width,nr,by))
#e <- embedi(nr, width, by, ascending)
if( nc==1 ) {
#xx <- apply(e, 1, function(i) FUN(data[i,],...))
#xx <- sapply(1:NROW(e), function(i) FUN(data[e[i,],],...))
##xx <- sapply(ind, function(i) FUN(data[(i-width+1):i,],...))
xx <- sapply(ind, function(i) FUN(.subset_xts(data,(i-width+1):i),...))
if(!is.null(dim(xx))) xx <- t(xx)
res <- xts(xx, tt, if (by == 1) attr(data, "frequency"))
} else if( by.column ) {
res <- xts( sapply( 1:NCOL(data), function(j)
#apply(e, 1, function(i) FUN(data[i,j],...)) ),
#apply(ind, 1, function(i) FUN(data[(i-width+1):i,j],...)) ),
apply(ind, 1, function(i) FUN(.subset_xts(data,(i-width+1):i,j),...)) ),
tt, if (by == 1) attr(data, "frequency") )
} else {
#xx <- apply(e, 1, function(i) FUN(data[i,],...))
##xx <- apply(ind, 1, function(i) FUN(data[(i-width+1):i,],...))
xx <- apply(ind, 1, function(i) FUN(.subset_xts(data,(i-width+1):i),...))
if(!is.null(dim(xx))) xx <- t(xx)
res <- xts(xx, tt, if (by == 1) attr(data, "frequency"))
}
ix <- index(data) %in% index(res)
tmp <- merge(res, xts(,idx, attr(data, "frequency")))
if(is.null(colnames(res))) {
# remove dimnames (xts objects don't have rownames)
dimnames(tmp) <- NULL
}
res <- na.fill(tmp, fill, ix)
if( by.column && !is.null(dim(data)) ) {
colnames(res) <- colnames(data)
}
return(res)
}
rollsum.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
align=c("right", "center", "left"), ...) {
## FIXME: align and fill are not respected!
# from rollapply.xts; is this necessary?
x <- try.xts(x)
# from rollmean.zoo
if (!missing(na.pad))
warning("na.pad is deprecated. Use fill.")
# process alignment
align <- match.arg(align)
#n1 <- switch(align,
# "left" = { k - 1 },
# "center" = { floor(k/2) },
# "right" = { 0 })
#ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
res <- .Call(C_roll_sum, x, k)
res
}
rollmean.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
align=c("right", "center", "left"), ...) {
rollsum.xts(x=x, k=k, fill=fill, align=align, ...) / k
}
rollmax.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
align=c("right", "center", "left"), ...) {
## FIXME: align and fill are not respected!
# from rollapply.xts; is this necessary?
x <- try.xts(x)
# from rollmean.zoo
if (!missing(na.pad))
warning("na.pad is deprecated. Use fill.")
# process alignment
align <- match.arg(align)
#n1 <- switch(align,
# "left" = { k - 1 },
# "center" = { floor(k/2) },
# "right" = { 0 })
#ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
res <- .Call(C_roll_max, x, k)
res
}
rollmin.xts <- function (x, k, fill=if(na.pad) NA, na.pad=TRUE,
align=c("right", "center", "left"), ...) {
## FIXME: align and fill are not respected!
# from rollapply.xts; is this necessary?
x <- try.xts(x)
# from rollmean.zoo
if (!missing(na.pad))
warning("na.pad is deprecated. Use fill.")
# process alignment
align <- match.arg(align)
#n1 <- switch(align,
# "left" = { k - 1 },
# "center" = { floor(k/2) },
# "right" = { 0 })
#ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
res <- .Call(C_roll_min, x, k)
res
}
rollcov.xts <- function (x, y, k, fill=if(na.pad) NA, na.pad=TRUE,
align=c("right", "center", "left"), sample=TRUE, ...) {
## FIXME: align and fill are not respected!
# from rollapply.xts; is this necessary?
x <- try.xts(x)
y <- try.xts(y)
# from rollmean.zoo
if (!missing(na.pad))
warning("na.pad is deprecated. Use fill.")
# process alignment
align <- match.arg(align)
#n1 <- switch(align,
# "left" = { k - 1 },
# "center" = { floor(k/2) },
# "right" = { 0 })
#ix <- index(x)[seq((k-n1), (nrow(x)-n1), 1)]
res <- .Call(C_roll_cov, x, y, k, sample)
res
}
xts/R/timeBasedSeq.R 0000644 0001762 0000144 00000015435 14654242576 014011 0 ustar ligges users #
# 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 2 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 .
#' Create a Sequence or Range of Times
#'
#' A function to create a vector of time-based objects suitable for indexing an
#' xts object, given a string conforming to the ISO-8601 time and date standard
#' for range-based specification. The resulting series can be of any class
#' supported by xts, including POSIXct, Date, chron, timeDate, yearmon, and
#' yearqtr.
#'
#' `timeBasedRange()` creates a one or two element numeric vector representing
#' the start and end number of seconds since epoch (1970-01-01). For internal
#' use.
#'
#' `timeBasedSeq()` creates sequences of time-based observations using strings
#' formatted according to the ISO-8601 specification. The general format is
#' *from/to/by* or *from::to::by*, where *to* and *by* are optional when the
#' 'length.out' argument is specified.
#'
#' The *from* and *to* elements of the string must be left-specified with
#' respect to the standard *CCYYMMDD HHMMSS* form. All dates/times specified
#' will be set to either the earliest point (from) or the latest (to), to the
#' given the level of specificity. For example, \sQuote{1999} in the *from*
#' field would set the start to the beginning of 1999. \sQuote{1999} in the
#' *to* field would set the end to the end of 1999.
#'
#' The amount of resolution in the result is determined by the resolution of
#' the *from* and *to* component, unless the optional *by* component is
#' specified.
#'
#' For example, `timeBasedSeq("1999/2008")` returns a vector of Dates for
#' January 1st of each year. `timeBasedSeq("199501/1996")` returns a yearmon
#' vector of 24 months in 1995 and 1996. And `timeBasedSeq("19950101/1996")`
#' creates a Date vector for all the days in those two years.
#'
#' The optional *by* field (the third delimited element to the string), will
#' the resolution heuristic described above and will use the specified *by*
#' resolution. The possible values for *by* are: 'Y' (years), 'm' (months),
#' 'd' (days), 'H' (hours), 'M' (minutes), 'S' (seconds). Sub-second
#' resolutions are not supported.
#'
#' @param x An ISO-8601 time-date range string.
#' @param retclass The return class desired.
#' @param length.out Passed to `seq()` internally.
#' @param \dots Unused.
#'
#' @return `timeBasedSeq()` returns a vector of time-based observations.
#' `timeBasedRange()` returns a one or two element numeric vector representing
#' the start and end number of seconds since epoch (1970-01-01).
#'
#' When `retclass = NULL`, the result of `timeBasedSeq()` is a named list
#' containing elements "from", "to", "by" and "length.out".
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`timeBased()`], [`xts()`]
#'
#' @references International Organization for Standardization: ISO 8601
#'
#'
#' @keywords utilities
#' @examples
#'
#' timeBasedSeq('1999/2008')
#' timeBasedSeq('199901/2008')
#' timeBasedSeq('199901/2008/d')
#' timeBasedSeq('20080101 0830',length=100) # 100 minutes
#' timeBasedSeq('20080101 083000',length=100) # 100 seconds
#'
`timeBasedSeq` <-
function(x, retclass=NULL, length.out=NULL) {
if(!is.character(x))
# allows for unquoted numerical expressions to work
x <- deparse(match.call()$x)
x <- gsub('::','/',x, perl=TRUE) # replace all '::' range ops with '/'
x <- gsub('[-:]','',x, perl=TRUE) # strip all remaining '-' and ':' seps
x <- gsub('[ ]','',x, perl=TRUE) # strip all remaining white space
x <- unlist(strsplit(x,"/"))
from <- x[1]
to <- x[2]
BY <- x[3]
# need to test for user specified length.out, currently just overriding
if(from == "")
from <- NA
if(!is.na(from)) {
year <- as.numeric(substr(from,1,4))
month <- as.numeric(substr(from,5,6))
day <- as.numeric(substr(from,7,8))
hour <- as.numeric(substr(from,9,10))
mins <- as.numeric(substr(from,11,12))
secs <- as.numeric(substr(from,13,14))
time.args.from <- as.list(unlist(sapply(c(year,month,day,hour,mins,secs),
function(x) if(!is.na(x)) x)
))
from <- do.call('firstof',time.args.from)
}
else time.args.from <- list()
# only calculate if to is specified
if(!is.na(to)) {
year <- as.numeric(substr(to,1,4))
month <- as.numeric(substr(to,5,6))
day <- as.numeric(substr(to,7,8))
hour <- as.numeric(substr(to,9,10))
mins <- as.numeric(substr(to,11,12))
secs <- as.numeric(substr(to,13,14))
time.args.to <- as.list(unlist(sapply(c(year,month,day,hour,mins,secs),
function(x) if(!is.na(x)) x)
))
to <- do.call('lastof',time.args.to)
}
else time.args.to <- list()
max.resolution <- max(length(time.args.from), length(time.args.to))
# if neither is set
if(max.resolution == 0)
max.resolution <- 1
resolution <- c('year','month','DSTday','hour','mins','secs')[max.resolution]
if(!is.na(BY)) resolution <- names(match.arg(BY, list(year ='Y',
month ='m',
day ='d',
hour ='H',
mins ='M',
secs ='S')))
convert.to <- 'Date'
if(max.resolution == 2 || resolution == 'month' ) convert.to <- 'yearmon'
if(max.resolution > 3 || resolution %in% c("hour","mins","secs")) convert.to <- 'POSIXct'
if(is.na(to) && missing(length.out))
length.out <- 1L
if(((!missing(retclass) && is.null(retclass)) || any(is.na(to),is.na(from)))) {
# return the calculated values only
return(list(from=from,to=to,by=resolution,length.out=length.out))
}
if(is.null(length.out)) {
SEQ <- seq(from,to,by=resolution)
} else {
SEQ <- seq(from, by=resolution, length.out=length.out)
}
if(!is.null(retclass)) convert.to <- retclass
if(convert.to == 'POSIXct') {
structure(SEQ, class=c('POSIXct','POSIXt')) # need to force the TZ to be used
} else
do.call(paste('as',convert.to,sep='.'), list(SEQ))
}
xts/R/period.R 0000644 0001762 0000144 00000011147 14654242576 012721 0 ustar ligges users #
# 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 2 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 .
#' Check if Class is Time-Based
#'
#' Used to verify that the object is one of the known time-based classes in R.
#' Current time-based objects supported are `Date`, `POSIXct`, `chron`,
#' `yearmon`, `yearqtr`, and `timeDate`.
#'
#' @param x Object to test.
#'
#' @return A logical scalar.
#'
#' @author Jeffrey A. Ryan
#'
#' @rdname timeBased
#' @keywords utilities
#' @examples
#'
#' timeBased(Sys.time())
#' timeBased(Sys.Date())
#'
#' timeBased(200701)
#'
`is.timeBased` <-
function(x) {
time.classes <-
c("Date", "POSIXt", "chron", "dates", "times", "timeDate",
"yearmon", "yearqtr", "xtime")
inherits(x, time.classes)
}
#' @rdname timeBased
`timeBased` <- `is.timeBased`
#' Optimized Calculations By Period
#'
#' Calculate a sum, product, minimum, or maximum for each non-overlapping
#' period specified by `INDEX`.
#'
#' These functions are similar to calling `period.apply()` with the same
#' endpoints and function. There may be slight differences in the results due
#' to numerical accuracy.
#'
#' For xts-coercible objects, an appropriate `INDEX` can be created by a call
#' to `endpoints()`.
#'
#' @param x A univariate data object.
#' @param INDEX A numeric vector of endpoints for each period.
#'
#' @return An xts or zoo object containing the sum, product, minimum, or
#' maximum for each endpoint in `INDEX`.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`endpoints()`], [`period.apply()`]
#'
#' @keywords utilities
#' @rdname period_math
#' @examples
#'
#' x <- c(1, 1, 4, 2, 2, 6, 7, 8, -1, 20)
#' i <- c(0, 3, 5, 8, 10)
#'
#' period.sum(x, i)
#' period.prod(x, i)
#' period.min(x, i)
#' period.max(x, i)
#'
#' data(sample_matrix)
#' y <- sample_matrix[, 1]
#' ep <- endpoints(sample_matrix)
#'
#' period.sum(y, ep)
#' period.sum(as.xts(y), ep)
#'
#' period.prod(y, ep)
#' period.prod(as.xts(y), ep)
#'
#' period.min(y, ep)
#' period.min(as.xts(y), ep)
#'
#' period.max(y, ep)
#' period.max(as.xts(y), ep)
#'
`period.sum` <-
function(x,INDEX) {
if(NCOL(x) > 1) stop("single column data only")
if(min(INDEX) < 0 || max(INDEX) > NROW(x)) stop("INDEX must be >= 0 and <= nrow(x)")
ep <- as.integer(INDEX)
if(ep[1L] != 0L) ep <- c(0L,ep)
if(ep[length(ep)] != NROW(x)) ep <- c(ep,NROW(x))
xx <- as.double(x)
xa <- .Call(C_xts_period_sum, xx, ep)
if(timeBased(index(x))) {
tz <- xts(xa, index(x)[ep[-1]])
} else {
tz <- zoo(xa, index(x)[ep[-1]])
}
tz
}
#' @rdname period_math
`period.prod` <-
function(x,INDEX) {
if(NCOL(x) > 1) stop("single column data only")
if(min(INDEX) < 0 || max(INDEX) > NROW(x)) stop("INDEX must be >= 0 and <= nrow(x)")
ep <- as.integer(INDEX)
if(ep[1] != 0L) ep <- c(0L,ep)
if(ep[length(ep)] != NROW(x)) ep <- c(ep,NROW(x))
xx <- as.double(x)
xa <- .Call(C_xts_period_prod, xx, ep)
if(timeBased(index(x))) {
tz <- xts(xa, index(x)[ep[-1]])
} else {
tz <- zoo(xa, index(x)[ep[-1]])
}
tz
}
#' @rdname period_math
`period.max` <-
function(x,INDEX) {
if(NCOL(x) > 1) stop("single column data only")
if(min(INDEX) < 0 || max(INDEX) > NROW(x)) stop("INDEX must be >= 0 and <= nrow(x)")
ep <- as.integer(INDEX)
if(ep[1] != 0L) ep <- c(0L,ep)
if(ep[length(ep)] != NROW(x)) ep <- c(ep,NROW(x))
xx <- as.double(x)
xa <- .Call(C_xts_period_max, xx, ep)
if(timeBased(index(x))) {
tz <- xts(xa, index(x)[ep[-1]])
} else {
tz <- zoo(xa, index(x)[ep[-1]])
}
tz
}
#' @rdname period_math
`period.min` <-
function(x,INDEX) {
if(NCOL(x) > 1) stop("single column data only")
if(min(INDEX) < 0 || max(INDEX) > NROW(x)) stop("INDEX must be >= 0 and <= nrow(x)")
ep <- as.integer(INDEX)
if(ep[1] != 0L) ep <- c(0L,ep)
if(ep[length(ep)] != NROW(x)) ep <- c(ep,NROW(x))
xx <- as.double(x)
xa <- .Call(C_xts_period_min, xx, ep)
if(timeBased(index(x))) {
tz <- xts(xa, index(x)[ep[-1]])
} else {
tz <- zoo(xa, index(x)[ep[-1]])
}
tz
}
xts/R/as.environment.xts.R 0000644 0001762 0000144 00000003424 14654242576 015221 0 ustar ligges users #
# 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 2 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 .
#' Coerce an xts Object to an Environment by Column
#'
#' Method to automatically convert an xts object to an environment containing
#' vectors representing each column of the original xts object. The name of
#' each object in the resulting environment corresponds to the name of the
#' column of the xts object.
#'
#' @param x An xts object.
#'
#' @return An environment containing `ncol(x)` vectors extracted by
#' column from `x`.
#'
#' @note Environments do not preserve (or have knowledge) of column order and
#' cannot be subset by an integer index.
#'
#' @author Jeffrey A. Ryan
#'
#' @keywords manip
#' @examples
#'
#' x <- xts(1:10, Sys.Date()+1:10)
#' colnames(x) <- "X"
#' y <- xts(1:10, Sys.Date()+1:10)
#' colnames(x) <- "Y"
#' xy <- cbind(x,y)
#' colnames(xy)
#' e <- as.environment(xy) # currently using xts-style positive k
#' ls(xy)
#' ls.str(xy)
#'
as.environment.xts <- function(x) {
e <- new.env()
lapply(1:NCOL(x), function(.) assign(colnames(x)[.], x[,.],envir=e))
e
}
xts/R/yearmon.R 0000644 0001762 0000144 00000001707 14654242576 013112 0 ustar ligges users #
# 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 2 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 .
#' @rdname as.xts
as.xts.yearmon <- function(x, ...)
{
xts(x=NULL, order.by=x)
}
#' @rdname as.xts
as.xts.yearqtr <- function(x, ...)
{
xts(x=NULL, order.by=x)
}
xts/R/axTicksByTime.R 0000644 0001762 0000144 00000011147 14654242576 014157 0 ustar ligges users #
# 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 2 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 .
#' Compute x-Axis Tickmark Locations by Time
#'
#' Compute x-axis tickmarks like [`axTicks()`] in base but with respect to
#' time. This function is written for internal use, and documented for those
#' wishing to use it for customized plots.
#'
#' The default `ticks.on = "auto"` uses heuristics to compute sensible tick
#' locations. Use a combination of `ticks.on` and `k` to create tick locations
#' at specific intervals. For example, `ticks.on = "days"` and `k = 7` will
#' create tick marks every 7 days.
#'
#' When `format.labels` is a character string the possible values are the same
#' as those listed in the Details section of [`strptime()`].
#'
#' @param x An object indexed by time or a vector of times/dates.
#' @param ticks.on Time unit for tick locations.
#' @param k Frequency of tick locations.
#' @param labels Should a labeled vector be returned?
#' @param format.labels Either a logical value specifying whether labels should
#' be formatted, or a character string specifying the format to use.
#' @param ends Should the ends be adjusted?
#' @param gt Lower bound on number of tick locations.
#' @param lt Upper bound on number of tick locations.
#'
#' @return A numeric vector of index element locations where tick marks should
#' be drawn. These are *locations* (e.g. 1, 2, 3, ...), *not* the
#' index timestamps.
#'
#' If possible, the result will be named using formatted values from the index
#' timestamps. The names will be used for the tick mark labels.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`endpoints()`]
#' @keywords utilities
#' @examples
#'
#' data(sample_matrix)
#' axTicksByTime(as.xts(sample_matrix),'auto')
#' axTicksByTime(as.xts(sample_matrix),'weeks')
#' axTicksByTime(as.xts(sample_matrix),'months',7)
#'
axTicksByTime <-
function(x, ticks.on = "auto", k = 1, labels = TRUE, format.labels = TRUE,
ends = TRUE, gt = 2, lt = 30)
{
# if a vector of times/dates, convert to dummy xts object
if (timeBased(x)) {
x <- xts(rep(1, length(x)), x)
}
ticks.on <- ticks.on[1L]
# special-case for "secs" and "mins"
if (ticks.on == "secs" || ticks.on == "mins") {
ticks.on <- substr(ticks.on, 1L, 3L)
}
tick.opts <- c("years", "quarters", "months", "weeks", "days", "hours",
"minutes", "seconds")
ticks.on <- match.arg(ticks.on, c("auto", tick.opts))
if (ticks.on == "auto") {
tick.k.opts <- c(10, 5, 2, 1, 3, 6, 1, 1, 1, 4, 2, 1, 30, 15, 1, 1)
tick.opts <- rep(tick.opts, c(4, 1, 2, 1, 1, 3, 3, 1))
is <- structure(rep(0, length(tick.opts)), .Names = tick.opts)
for (i in 1:length(tick.opts)) {
ep <- endpoints(x, tick.opts[i], tick.k.opts[i])
is[i] <- length(ep) - 1
if (is[i] > lt) {
break
}
}
loc <- rev(which(is > gt & is < lt))[1L]
cl <- tick.opts[loc]
ck <- tick.k.opts[loc]
} else {
cl <- ticks.on[1L]
ck <- k
}
if (is.null(cl) || is.na(cl) || is.na(ck)) {
ep <- c(0, NROW(x))
} else {
ep <- endpoints(x, cl, ck)
}
if (ends) {
ep <- ep + c(rep(1, length(ep) - 1), 0)
}
if (labels) {
if (is.logical(format.labels) || is.character(format.labels)) {
# format by platform...
unix <- (.Platform$OS.type == "unix")
# ...and level of time detail
fmt <- switch(periodicity(x)$scale,
weekly = ,
daily = if (unix) "%b %d%n%Y" else "%b %d %Y",
minute = ,
hourly = if (unix) "%b %d%n%H:%M" else "%b %d %H:%M",
seconds = if (unix) "%b %d%n%H:%M:%S" else "%b %d %H:%M:%S",
if (unix) "%n%b%n%Y" else "%b %Y")
# special case yearqtr index
if (inherits(index(x), "yearqtr")) {
fmt <- "%Y-Q%q"
}
if (is.character(format.labels)) {
fmt <- format.labels
}
names(ep) <- format(index(x)[ep], fmt)
} else {
names(ep) <- as.character(index(x)[ep])
}
}
ep
}
xts/R/reclass.R 0000644 0001762 0000144 00000016760 14703317760 013072 0 ustar ligges users #
# 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 2 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 .
#' @rdname reclass
#' @aliases use.xts
try.xts <- function(x, ..., error=TRUE)
{
if(is.xts(x)) {
#attr(x,'.RECLASS') <- FALSE
return(x)
}
xx <- try(as.xts(x,..., .RECLASS=TRUE),silent=TRUE)
if(inherits(xx,'try-error')) {
if(is.character(error)) {
stop(error)
} else
if(is.function(error)) {
return(error(x, ...))
} else
if(error) {
stop(gsub('\n','',xx))
} else {
return(x)
}
} else {
# made positive: now test if needs to be reclassed
structure(xx, .RECLASS=TRUE)
}
}
use.xts <- try.xts
#' Convert Objects to xts and Back to Original Class
#'
#' Functions to convert objects of arbitrary classes to xts and then back to
#' the original class, without losing any attributes of the original class.
#'
#' A simple and reliable way to convert many different objects into a uniform
#' format for use within \R.
#'
#' `try.xts()` and `reclass()` are functions that enable external developers
#' access to the reclassing tools within \pkg{xts} to help speed development of
#' time-aware functions, as well as provide a more robust and seemless end-user
#' experience, regardless of the end-user's choice of data-classes.
#'
#' `try.xts()` calls `as.xts()` internally. See [`as.xts()`] for available xts
#' methods and arguments for each coercible class. Since it calls `as.xts()`,
#' you can add custom attributes as `name = value` pairs in the same way. But
#' these custom attributes will not be copied back to the original object when
#' `reclass()` is called.
#'
#' The `error` argument can be a logical value indicating whether an error
#' should be thrown (or fail silently), a character string allowing for custom
#' error error messages, or a function of the form `f(x, ...)` that will be
#' called if the conversion fails.
#'
#' `reclass()` converts an object created by `try.xts()` back to its original
#' class with all the original attributes intact (unless they were changed
#' after the object was converted to xts). The `match.to` argument allows you
#' copy the index attributes ([`tclass`], [`tformat`], and [`tzone`]) and
#' [`xtsAttributes()`] from another xts object to the result. `match.to` must
#' be an xts object with an index value for every observation in `x`.
#'
#' `Reclass()` is designed for top-level use, where it is desirable to have
#' the object returned from an arbitrary function in the same class as the
#' object passed in. Most functions in \R are not designed to return objects
#' matching the original object's class. It attempts to handle conversion and
#' reconversion transparently but it requires the original object must be
#' coercible to xts, the result of the function must have the same number of
#' rows as the input, and the object to be converted/reclassed must be the
#' first argument to the function being wrapped. Note that this function
#' hasn't been tested for robustness.
#'
#' See the accompanying vignette for more details on the above usage.
#'
#' @param x Data object to convert. See details for supported types.
#' @param match.to An xts object whose attributes will be copied to the result.
#' @param error Error handling option. See Details.
#' @param \dots Additional parameters or attributes.
#'
#' @return `try.xts()` returns an xts object when conversion is successful.
#' The `error` argument controls the function's behavior when conversion fails.
#'
#' `Reclass()` and `reclass()` return the object as its original class, as
#' specified by the 'CLASS' attribute.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`as.xts()`]
#'
#' @keywords utilities
#' @examples
#'
#' a <- 1:10
#'
#' # fails silently, the result is still an integer vector
#' try.xts(a, error = FALSE)
#'
#' # control the result with a function
#' try.xts(a, error = function(x, ...) { "I'm afraid I can't do that." })
#'
#' z <- zoo(1:10, timeBasedSeq("2020-01-01/2020-01-10"))
#' x <- try.xts(z) # zoo to xts
#' str(x)
#' str(reclass(x)) # reclass back to zoo
#'
`reclass` <-
function(x, match.to, error=FALSE, ...) {
if(!missing(match.to) && is.xts(match.to)) {
if(NROW(x) != length(.index(match.to)))
if(error) {
stop('incompatible match.to attibutes')
} else return(x)
if(!is.xts(x)) {
x <- .xts(coredata(x), .index(match.to),
tclass = tclass(match.to),
tzone = tzone(match.to),
tformat = tformat(match.to))
}
attr(x, ".CLASS") <- CLASS(match.to)
xtsAttributes(x) <- xtsAttributes(match.to)
tclass(x) <- tclass(match.to)
tformat(x) <- tformat(match.to)
tzone(x) <- tzone(match.to)
}
oldCLASS <- CLASS(x)
# should this be is.null(oldCLASS)?
if(length(oldCLASS) > 0 && !inherits(oldClass,'xts')) {
if(!is.null(dim(x))) {
if(!is.null(attr(x,'.ROWNAMES'))) {
# rownames<- (i.e. dimnames<-.xts) will not set row names
# force them directly
attr(x, "dimnames")[[1]] <- attr(x,'.ROWNAMES')[1:NROW(x)]
}
}
attr(x,'.ROWNAMES') <- NULL
#if(is.null(attr(x,'.RECLASS')) || attr(x,'.RECLASS')) {#should it be reclassed?
if(isTRUE(attr(x,'.RECLASS'))) {#should it be reclassed?
#attr(x,'.RECLASS') <- NULL
do.call(paste('re',oldCLASS,sep='.'),list(x))
} else {
#attr(x,'.RECLASS') <- NULL
x
}
} else {
#attr(x,'.RECLASS') <- NULL
x
}
}
#' @rdname reclass
#' @aliases use.reclass
Reclass <- function(x) {
xx <- match.call()
xxObj <- eval.parent(parse(text=all.vars(xx)[1]), 1)
inObj <- try.xts(xxObj, error=FALSE)
xx <- eval(match.call()[[-1]])
reclass(xx, inObj)
}
use.reclass <- Reclass
#' Extract and Set .CLASS Attribute
#'
#' Extraction and replacement functions to access the xts '.CLASS' attribute.
#' The '.CLASS' attribute is used by `reclass()` to transform an xts object
#' back to its original class.
#'
#' This is meant for use in conjunction with `try.xts()` and `reclass()` and is
#' is not intended for daily use. While it's possible to interactively coerce
#' objects to other classes than originally derived from, it's likely to cause
#' unexpected behavior. It is best to use the usual `as.xts()` and other
#' classes' `as` methods.
#'
#' @param x An xts object.
#' @param value The new value to assign to the '.CLASS' attribute.
#'
#' @return Called for its side-effect of changing the '.CLASS' attribute.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`as.xts()`], [`reclass()`]
#'
#' @keywords utilities
`CLASS` <-
function(x) {
cl <- attr(x,'.CLASS')
if(!is.null(cl)) {
attr(cl, 'class') <- 'CLASS'
return(cl)
}
return(NULL)
}
`print.CLASS` <-
function(x,...) {
cat(paste("previous class:",x),"\n")
}
#' @rdname CLASS
`CLASS<-` <-
function(x,value) {
UseMethod("CLASS<-")
}
`CLASS<-.xts` <-
function(x,value) {
attr(x,".CLASS") <- value
x
}
xts/R/POSIX.R 0000644 0001762 0000144 00000001560 14654242576 012337 0 ustar ligges users #
# 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 2 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 .
#' @rdname as.xts
as.xts.POSIXt <- function(x, ...)
{
xts(NULL, order.by=x)
}
xts/R/adj.time.R 0000644 0001762 0000144 00000002556 14654242576 013136 0 ustar ligges users #
# 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 2 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 .
#' @rdname align.time
adj.time <-
function(x, ...) {
tr <- match.call(expand.dots=FALSE)$...
if(length(tr) < 1) return(x)
oClass <- class(x)
x <- as.POSIXlt(x)
ntime <- as.environment(unclass(x))
lapply(tr, function(T) {
assign(all.vars(T), with(x, eval(T)), envir=ntime)
})
x <- structure(list(
sec=ntime$sec, min=ntime$min, hour=ntime$hour,
mday=ntime$mday, month=ntime$mon, year=ntime$year,
wday=ntime$wday, yday=ntime$yday,isdst=ntime$isdst), tzone=attr(x,"tzone"),
class=c("POSIXlt","POSIXt"))
do.call(paste('as',oClass[1],sep='.'), list(x))
}
xts/R/endpoints.R 0000644 0001762 0000144 00000015324 14654242576 013443 0 ustar ligges users #
# 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 2 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 .
#' Locate Endpoints by Time
#'
#' Extract index locations for an xts object that correspond to the *last*
#' observation in each period specified by `on` and `k`.
#'
#' `endpoints()` returns a numeric vector that always begins with zero and ends
#' with the number of observations in `x`.
#'
#' Periods are always based on the distance from the UNIX epoch (midnight
#' 1970-01-01 UTC), *not the first observation in `x`*. See the examples.
#'
#' Valid values for the `on` argument are: \dQuote{us} (microseconds),
#' \dQuote{microseconds}, \dQuote{ms} (milliseconds), \dQuote{milliseconds},
#' \dQuote{secs} (seconds), \dQuote{seconds}, \dQuote{mins} (minutes),
#' \dQuote{minutes}, \dQuote{hours}, \dQuote{days}, \dQuote{weeks},
#' \dQuote{months}, \dQuote{quarters}, and \dQuote{years}.
#'
#' @param x An xts object.
#' @param on A character string specifying the period.
#' @param k The number of periods each endpoint should cover.
#'
#' @return A numeric vector of beginning with 0 and ending with the number of
#' of observations in `x`.
#'
#' @author Jeffrey A. Ryan
#' @keywords utilities
#' @examples
#'
#' data(sample_matrix)
#'
#' endpoints(sample_matrix)
#' endpoints(sample_matrix, "weeks")
#'
#' ### example of how periods are based on the UNIX epoch,
#' ### *not* the first observation of the data series
#' x <- xts(1:38, yearmon(seq(2018 - 1/12, 2021, 1/12)))
#' # endpoints for the end of every other year
#' ep <- endpoints(x, "years", k = 2)
#' # Dec-2017 is the end of the *first* year in the data. But when you start from
#' # Jan-1970 and use every second year end as your endpoints, the endpoints are
#' # always December of every odd year.
#' x[ep, ]
#'
endpoints <-
function(x,on='months',k=1) {
if(k < 1) {
stop("'k' must be > 0")
}
if(timeBased(x)) {
NR <- length(x)
x <- xts(, order.by=x)
} else NR <- NROW(x)
addlast <- TRUE # remove automatic NR last value
if(!is.xts(x))
x <- try.xts(x, error='must be either xts-coercible or timeBased')
# special-case "secs" and "mins" for back-compatibility
if(on == "secs" || on == "mins")
on <- substr(on, 1L, 3L)
on <- match.arg(on, c("years", "quarters", "months", "weeks", "days", "hours",
"minutes", "seconds", "milliseconds", "microseconds", "ms", "us"))
# 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(.POSIXct(.index(x)),tz=tzone(x))
include_last <- function(x, k) {
len <- length(x)
i <- seq(1L ,len, k)
if(i[length(i)] != len) {
i <- c(i, len)
}
ep[i]
}
switch(on,
"years" = {
as.integer(c(0, which(diff(posixltindex$year %/% k + 1) != 0), NR))
},
"quarters" = {
ixyear <- posixltindex$year * 100L + 190000L
ixqtr <- ixyear + posixltindex$mon %/% 3L + 1L
ep <- c(0L, which(diff(ixqtr) != 0L), NR)
if(k > 1) {
ep <- include_last(ep, k)
}
ep
},
"months" = {
ixmon <- posixltindex$year * 100L + 190000L + posixltindex$mon
ep <- .Call(C_endpoints, ixmon, 1L, 1L, addlast)
if(k > 1) {
ep <- include_last(ep, k)
}
ep
},
"weeks" = {
.Call(C_endpoints, .index(x)+3L*86400L, 604800L, k, addlast)
},
"days" = {
ixyday <- posixltindex$year * 1000L + 1900000L + posixltindex$yday
.Call(C_endpoints, ixyday, 1L, k, addlast)
},
# non-date slicing should be indifferent to TZ and DST, so use math instead
"hours" = {
.Call(C_endpoints, .index(x), 3600L, k, addlast)
},
"minutes" = {
.Call(C_endpoints, .index(x), 60L, k, addlast)
},
"seconds" = {
.Call(C_endpoints, .index(x), 1L, k, addlast)
},
"ms" = ,
"milliseconds" = {
sec2ms <- .index(x) * 1e3
.Call(C_endpoints, sec2ms, 1L, k, addlast)
},
"us" = ,
"microseconds" = {
sec2us <- .index(x) * 1e6
.Call(C_endpoints, sec2us, 1L, k, addlast)
}
)
}
`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]
}
#' Create a POSIXct Object
#'
#' Easily create of time stamps corresponding to the first or last observation
#' in a specified time period.
#'
#' This is a wrapper to [`ISOdatetime()`] with defaults corresponding to the
#' first or last possible time in a given period.
#'
#' @param year,month,day Numeric values to specify a day.
#' @param hour,min,sec Numeric vaues to specify time within a day.
#' @param tz Timezone used for conversion.
#'
#' @return An POSIXct object.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`ISOdatetime()`]
#'
#' @keywords utilities
#' @examples
#'
#' firstof(2000)
#' firstof(2005,01,01)
#'
#' lastof(2007)
#' lastof(2007,10)
#'
`firstof` <-
function(year=1970,month=1,day=1,hour=0,min=0,sec=0,tz="") {
ISOdatetime(year,month,day,hour,min,sec,tz)
}
#' @param subsec Number of sub-seconds.
#' @rdname firstof
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])
}
# strptime has an issue (bug?) which returns NA when passed
# 1969-12-31-23-59-59; pass 58.9 secs instead.
sysTZ <- Sys.getenv("TZ")
if (length(c(year, month, day, hour, min, sec)) == 6 &&
all(c(year, month, day, hour, min, sec) == c(1969, 12, 31, 23, 59, 59)) &&
(sysTZ == "" || isUTC(sysTZ)))
sec <- sec-1
ISOdatetime(year, month, day, hour, min, sec, tz)
}
xts/R/xts.R 0000644 0001762 0000144 00000043152 14702273113 012237 0 ustar ligges users #
# 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 2 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 .
# xts() index attribute precedence should be:
# 1. .index* value (e.g. .indexTZ) # backward compatibility
# 2. t* value (e.g. tzone) # current function to override index attribute
# 3. attribute on order.by # overridden by either 2 above
#
# Do we always have to override the value of an existing tzone on the index
# because the default value is Sys.getenv("TZ")?
#
# .xts() index attribute precedence is similar. But we cannot override tclass
# because it's a formal argument with a specific default. Historically .xts()
# has always set the tclass to POSIXct by default, whether or not the 'index'
# argument already had a tclass attribute.
#' Create or Test For An xts Time-Series Object
#'
#' Constructor function for creating an extensible time-series object.
#'
#' `xts()` is used to create an xts object from raw data inputs. The xts class
#' inherits from and extends the zoo class, which means most zoo functions can
#' be used on xts objects.
#'
#' The `xts()` constructor is the preferred way to create xts objects. It
#' performs several checks to ensure it returns a well-formed xts object. The
#' `.xts()` constructor is mainly for internal use. It is more efficient then
#' the regular `xts()` constructor because it doesn't perform as many validity
#' checks. Use it with caution.
#'
#' Similar to zoo objects, xts objects must have an ordered index. While zoo
#' indexes cannot contain duplicate values, xts objects have optionally
#' supported duplicate index elements since version 0.5-0. The xts class has
#' one additional requirement: the index must be a time-based class. Currently
#' supported classes include: \sQuote{Date}, \sQuote{POSIXct}, \sQuote{timeDate},
#' as well as \sQuote{yearmon} and \sQuote{yearqtr} where the index values
#' remain unique.
#'
#' The uniqueness requirement was relaxed in version 0.5-0, but is still
#' enforced by default. Setting `unique = FALSE` skips the uniqueness check and
#' only ensures that the index is ordered via the `isOrdered()` function.
#'
#' As of version 0.10-0, xts no longer allows missing values in the index. This
#' is because many xts functions expect all index values to be finite. The most
#' important of these is `merge.xts()`, which is used ubiquitously. Missing
#' values in the index are usually the result of a date-time conversion error
#' (e.g. incorrect format, non-existent time due to daylight saving time, etc.).
#' Because of how non-finite numbers are represented, a missing timestamp will
#' always be at the end of the index (except if it is `-Inf`, which will be
#' first).
#'
#' Another difference from \pkg{zoo} is that xts object may carry additional
#' attributes that may be desired in individual time-series handling. This
#' includes the ability to augment the objects data with meta-data otherwise
#' not cleanly attachable to a standard zoo object. These attributes may be
#' assigned and extracted via [`xtsAttributes()`] and [`xtsAttributes<-`],
#' respectively.
#'
#' Examples of usage from finance may include the addition of data for keeping
#' track of sources, last-update times, financial instrument descriptions or
#' details, etc.
#'
#' The idea behind \pkg{xts} is to offer the user the ability to utilize a
#' standard zoo object, while providing an mechanism to customize the object's
#' meta-data, as well as create custom methods to handle the object in a manner
#' required by the user.
#'
#' Many xts-specific methods have been written to better handle the unique
#' aspects of xts. These include, subsetting (`[`), `merge()`, `cbind()`,
#' `rbind()`, `c()`, math and logical operations, `lag()`, `diff()`,
#' `coredata()`, `head()`, and `tail()`. There are also xts-specific methods
#' for converting to/from R's different time-series classes.
#'
#' Subsetting via `[` methods offers the ability to specify dates by range, if
#' they are enclosed in quotes. The style borrows from python by creating
#' ranges separated by a double colon \dQuote{"::"} or \dQuote{"/"}. Each side
#' of the range may be left blank, which would then default to the start and
#' end of the data, respectively. To specify a subset of times, it is only
#' required that the time specified be in standard ISO format, with some form
#' of separation between the elements. The time must be *left-filled*, that is
#' to specify a full year one needs only to provide the year, a month requires
#' the full year and the integer of the month requested - e.g. '1999-01'. This
#' format would extend all the way down to seconds - e.g. '1999-01-01 08:35:23'.
#' Leading zeros are not necessary. See the examples for more detail.
#'
#' Users may also extend the xts class to new classes to allow for method
#' overloading.
#'
#' Additional benefits derive from the use of [`as.xts()`] and [`reclass()`],
#' which allow for lossless two-way conversion between common R time-series
#' classes and the xts object structure. See those functions for more detail.
#'
#' @param x An object containing the underlying data.
#' @param order.by A corresponding vector of dates/times of a known time-based
#' class. See Details.
#' @param index A corresponding *numeric* vector specified as seconds since
#' the UNIX epoch (1970-01-01 00:00:00.000).
#' @param frequency Numeric value indicating the frequency of `order.by`. See
#' details.
#' @param unique Can the index only include unique timestamps? Ignored when
#' `check = FALSE`.
#' @param check Must the index be ordered? The index cannot contain duplicates
#' when `check = TRUE` and `unique = TRUE`.
#' @param tclass Time class to use for the index. See [`tclass()`].
#' @param tzone Time zone of the index (ignored for indices without a time
#' component, e.g. Date, yearmon, yearqtr). See [`tzone()`].
#' @param \dots Additional attributes to be added. See details.
#'
#' @return An S3 object of class xts.
#'
#' @author Jeffrey A. Ryan and Joshua M. Ulrich
#'
#' @seealso [`as.xts()`], [`index()`][xts::index.xts], [`tclass()`], [`tformat()`], [`tzone()`],
#' [`xtsAttributes()`]
#'
#' @references \pkg{zoo}
#'
#' @keywords utilities
#' @examples
#'
#' data(sample_matrix)
#' sample.xts <- as.xts(sample_matrix, descr='my new xts object')
#'
#' class(sample.xts)
#' str(sample.xts)
#'
#' head(sample.xts) # attribute 'descr' hidden from view
#' attr(sample.xts,'descr')
#'
#' sample.xts['2007'] # all of 2007
#' sample.xts['2007-03/'] # March 2007 to the end of the data set
#' sample.xts['2007-03/2007'] # March 2007 to the end of 2007
#' sample.xts['/'] # the whole data set
#' sample.xts['/2007'] # the beginning of the data through 2007
#' sample.xts['2007-01-03'] # just the 3rd of January 2007
#'
`xts` <-
function(x=NULL,
order.by=index(x),
frequency=NULL,
unique=TRUE,
tzone=Sys.getenv("TZ"),
...)
{
if(is.null(x) && missing(order.by))
return(.xts(NULL, integer()))
if(!timeBased(order.by))
stop("order.by requires an appropriate time-based object")
#if(NROW(x) != length(order.by))
if(NROW(x) > 0 && NROW(x) != length(order.by))
stop("NROW(x) must match length(order.by)")
order.by_ <- order.by # make local copy and don't change order.by
if(inherits(order.by, 'Date')) {
# convert to GMT POSIXct if specified
order.by_ <- .POSIXct(unclass(order.by) * 86400, tz = "UTC")
}
if(!isOrdered(order.by_, strictly = !unique)) {
indx <- order(order.by_)
if(!is.null(x)) {
if(NCOL(x) > 1 || is.matrix(x) || is.data.frame(x)) {
x <- x[indx,,drop=FALSE]
} else x <- x[indx]
}
order.by_ <- order.by_[indx]
}
if(is.null(x)) {
x <- numeric(0)
} else if (is.list(x)) {
# list or data.frame
if (is.data.frame(x)) {
x <- as.matrix(x)
} else {
stop("cannot convert lists to xts objects")
}
} else if (NROW(x) > 0) {
x <- as.matrix(x)
}
# else 'x' is a zero-length vector. Do not *add* dims via as.matrix().
# It's okay if 'x' already has dims.
if(inherits(order.by, "dates")) {
fmt <- "%m/%d/%y"
if(inherits(order.by, "chron")) {
fmt <- paste0("(", fmt, " %H:%M:%S)")
}
order.by_ <- strptime(as.character(order.by_), fmt) # POSIXlt
}
index <- as.numeric(as.POSIXct(order.by_))
if(any(!is.finite(index)))
stop("'order.by' cannot contain 'NA', 'NaN', or 'Inf'")
# process index attributes
ctor.call <- match.call(expand.dots = TRUE)
tformat. <- attr(order.by, "tformat")
if(hasArg(".indexFORMAT")) {
warning(sQuote(".indexFORMAT"), " is deprecated, use tformat instead.")
tformat. <- eval.parent(ctor.call$.indexFORMAT)
} else if(hasArg("tformat")) {
tformat. <- eval.parent(ctor.call$tformat)
}
tclass. <- attr(order.by, "tclass")
if(hasArg(".indexCLASS")) {
warning(sQuote(".indexCLASS"), " is deprecated, use tclass instead.")
tclass. <- eval.parent(ctor.call$.indexCLASS)
} else if(hasArg("tclass")) {
tclass. <- eval.parent(ctor.call$tclass)
} else if(is.null(tclass.)) {
tclass. <- class(order.by)
if(inherits(order.by, "POSIXt")) {
#tclass. <- tclass.[tclass. != "POSIXt"]
}
}
tzone. <- tzone # default Sys.getenv("TZ")
if(hasArg(".indexTZ")) {
warning(sQuote(".indexTZ"), " is deprecated, use tzone instead.")
tzone. <- eval.parent(ctor.call$.indexTZ)
} else if(hasArg("tzone")) {
tzone. <- eval.parent(ctor.call$tzone)
} else {
# no tzone argument
if(inherits(order.by, "timeDate")) {
tzone. <- order.by@FinCenter
} else if(!is.null(attr(order.by, "tzone"))) {
tzone. <- attr(order.by, "tzone")
}
}
if(isClassWithoutTZ(object = order.by)) {
if((hasArg(".indexTZ") || hasArg("tzone")) && !isUTC(tzone.)) {
warning(paste(sQuote('tzone'),"setting ignored for ",
paste(class(order.by), collapse=", "), " indexes"))
}
tzone. <- "UTC" # change anything in isUTC() to UTC
}
# xts' tzone must only contain one element (POSIXlt tzone has 3)
tzone. <- tzone.[1L]
x <- structure(.Data = x,
index = structure(index, tzone = tzone.,
tclass = tclass., tformat = tformat.),
class=c('xts','zoo'),
...)
# remove any index attributes that came through '...'
index.attr <- c(".indexFORMAT", "tformat",
".indexCLASS", "tclass",
".indexTZ", "tzone")
for(iattr in index.attr) {
attr(x, iattr) <- NULL
}
if(!is.null(attributes(x)$dimnames[[1]]))
# this is very slow if user adds rownames, but maybe that is deserved :)
dimnames(x) <- dimnames(x) # removes row.names
x
}
#' @rdname xts
`.xts` <-
function(x=NULL, index, tclass=c("POSIXct","POSIXt"),
tzone=Sys.getenv("TZ"),
check=TRUE, unique=FALSE, ...) {
if(check) {
if( !isOrdered(index, increasing=TRUE, strictly=unique) )
stop('index is not in ',ifelse(unique, 'strictly', ''),' increasing order')
}
index_out <- index
if(!is.numeric(index) && timeBased(index))
index_out <- as.numeric(as.POSIXct(index))
if(!is.null(x) && NROW(x) != length(index))
stop("index length must match number of observations")
if(any(!is.finite(index_out)))
stop("'index' cannot contain 'NA', 'NaN', or 'Inf'")
if(!is.null(x)) {
if(!is.matrix(x))
x <- as.matrix(x)
} else
if(length(x) == 0 && !is.null(x)) {
x <- vector(storage.mode(x))
} else x <- numeric(0)
# process index attributes
ctor.call <- match.call(expand.dots = TRUE)
tformat. <- attr(index, "tformat")
if(hasArg(".indexFORMAT")) {
warning(sQuote(".indexFORMAT"), " is deprecated, use tformat instead.")
tformat. <- eval.parent(ctor.call$.indexFORMAT)
} else if(hasArg("tformat")) {
tformat. <- eval.parent(ctor.call$tformat)
}
tclass. <- tclass # default POSIXct
if(hasArg(".indexCLASS")) {
warning(sQuote(".indexCLASS"), " is deprecated, use tclass instead.")
tclass. <- eval.parent(ctor.call$.indexCLASS)
} else if(hasArg("tclass")) {
tclass. <- eval.parent(ctor.call$tclass)
} else {
# no tclass argument
tclass. <- attr(index, "tclass")
if(is.null(tclass.) && timeBased(index)) {
tclass. <- class(index)
} else {
if(!identical(tclass., c("POSIXct", "POSIXt"))) {
# index argument has 'tclass' attribute but it will be ignored
# FIXME:
# This warning causes errors in dependencies (e.g. portfolioBacktest,
# when the warning is thrown from PerformanceAnalytics). Reinstate this
# warning after fixing downstream packages.
# warning("the index tclass attribute is ", index.class,
# " but will be changed to (POSIXct, POSIXt)")
tclass. <- tclass # default POSIXct
}
}
}
tzone. <- tzone # default Sys.getenv("TZ")
if(hasArg(".indexTZ")) {
warning(sQuote(".indexTZ"), " is deprecated, use tzone instead.")
tzone. <- eval.parent(ctor.call$.indexTZ)
} else if(hasArg("tzone")) {
tzone. <- eval.parent(ctor.call$tzone)
} else {
# no tzone argument
if(inherits(index, "timeDate")) {
tzone. <- index@FinCenter
} else if(!is.null(attr(index, "tzone"))) {
tzone. <- attr(index, "tzone")
}
}
if(isClassWithoutTZ(object = index)) {
if((hasArg(".indexTZ") || hasArg("tzone")) && !isUTC(tzone.)) {
warning(paste(sQuote('tzone'),"setting ignored for ",
paste(class(index), collapse=", "), " indexes"))
}
tzone. <- "UTC" # change anything in isUTC() to UTC
}
# xts' tzone must only contain one element (POSIXlt tzone has 3)
tzone <- tzone[1L]
xx <- .Call(C_add_xtsCoreAttributes, x, index_out, tzone., tclass.,
c('xts','zoo'), tformat.)
# remove any index attributes that came through '...'
# and set any user attributes (and/or dim, dimnames, etc)
dots.names <- eval(substitute(alist(...)))
if(length(dots.names) > 0L) {
dot.attrs <- list(...)
drop.attr <- c(".indexFORMAT", "tformat", ".indexCLASS", ".indexTZ")
dot.attrs[drop.attr] <- NULL
attributes(xx) <- c(attributes(xx), dot.attrs)
}
# ensure there are no rownames (they may have come though dimnames)
rn <- dimnames(xx)[[1]]
if(!is.null(rn)) {
attr(xx, '.ROWNAMES') <- rn
dimnames(xx)[1] <- list(NULL)
}
xx
}
#' @rdname xts
`is.xts` <-
function(x) {
inherits(x,'xts') &&
is.numeric(.index(x)) &&
!is.null(tclass(x))
}
#' Convert Objects To and From xts
#'
#' Conversion S3 methods to coerce data objects of arbitrary classes to xts
#' and back, without losing any attributes of the original format.
#'
#' A simple and reliable way to convert many different objects into a uniform
#' format for use within \R.
#'
#' `as.xts()` can convert objects of the following classes into an xts object:
#' object: [timeSeries][timeSeries::timeSeries], [ts], [matrix], [data.frame],
#' and [zoo][zoo::zoo]. `xtsible()` safely checks whether an object can be converted to
#' an xts object.
#'
#' Additional `name = value` pairs may be passed to the function to be added to
#' the new object. A special [`print.xts()`] method ensures the attributes are
#' hidden from view, but will be available via \R's standard `attr()` function,
#' as well as the [`xtsAttributes()`] function.
#'
#' When `.RECLASS = TRUE`, the returned xts object internally preserves all
#' relevant attribute/slot data from the input `x`. This allows for temporary
#' conversion to xts in order to use zoo and xts compatible methods. See
#' [`reclass()`] for details.
#'
#' @param x Data object to convert. See details for supported types.
#' @param dateFormat What class should the dates be converted to?
#' @param FinCenter,recordIDs,title,documentation See [timeSeries][timeSeries::timeSeries] help.
#' @param order.by,frequency See [zoo][zoo::zoo] help.
#' @param \dots Additional parameters or attributes.
#' @param .RECLASS Should the conversion be reversible via [`reclass()`]?
#'
#' @return An S3 object of class xts.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`xts()`], [`reclass()`], [`zoo()`][zoo::zoo]
#'
#' @keywords utilities
#' @examples
#'
#' \dontrun{
#' # timeSeries
#' library(timeSeries)
#' x <- timeSeries(1:10, 1:10)
#'
#' str(as.xts(x))
#' str(reclass(as.xts(x)))
#' str(try.xts(x))
#' str(reclass(try.xts(x)))
#' }
#'
`as.xts` <-
function(x,...) {
UseMethod('as.xts')
}
#' @rdname as.xts
xtsible <- function(x)
{
if(inherits(try(as.xts(x),silent=TRUE),'try-error')) {
FALSE
} else TRUE
}
`re.xts` <-
function(x,...) {
# simply return the object
return(x)
}
`as.xts.xts` <-
function(x,...,.RECLASS=FALSE) {
# Cannot use 'zoo()' on objects of class 'zoo' or '.CLASS' (etc.?)
# Is the equivalent of a 'coredata.xts' needed? - jmu
#yy <- coredata(x)
#attr(yy, ".CLASS") <- NULL
# using new coredata.xts method - jar
if(length(x) == 0 && (!is.null(index(x)) && length(index(x))==0))
return(x)
if(.RECLASS) {
xx <- xts(coredata(x),
order.by=index(x),
.CLASS='xts',
...)
} else {
xx <- xts(coredata(x),
order.by=index(x),
...)
}
xx
}
xts/R/startOfYear.R 0000644 0001762 0000144 00000002016 14654242576 013675 0 ustar ligges users #
# 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 2 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 .
`startOfYear` <- function(from=1900,
to=2200,
origin=1970)
{
.Call(C_do_startofyear,
from = as.integer(from),
to = as.integer(to),
origin = as.integer(origin))
}
xts/R/utils.R 0000644 0001762 0000144 00000002026 14654242576 012573 0 ustar ligges users #
# 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 2 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 .
naCheck <- function(x, n=0) {
if(is.null(dim(x)[2])) {
NAs <- .Call(C_naCheck, x, TRUE)
} else NAs <- .Call(C_naCheck, rowSums(x), TRUE)
ret <- list()
ret$NAs <- NAs
ret$nonNA <- (1+NAs):NROW(x)
ret$beg <- n+NAs
invisible(ret)
}
xts/R/first.R 0000644 0001762 0000144 00000015656 14654242576 012577 0 ustar ligges users #
# 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 2 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 .
#' Return First or Last n Elements of A Data Object
#'
#' Generic functions to return the first or last elements or rows of a vector
#' or two-dimensional data object.
#'
#' A more advanced subsetting is available for zoo objects with indexes
#' inheriting from POSIXt or Date classes.
#'
#' Quickly and easily extract the first or last `n` observations of an object.
#' When `n` is a number, these functions are similar to [`head()`] and
#' [`tail()`], but only return the *first* or *last* observation by default.
#'
#' `n` can be a character string if `x` is an xts object or coerceable to xts.
#' It must be of the form \sQuote{n period}, where 'n' is a numeric value
#' (1 if not provided) describing the number of periods to return. Valid
#' periods are: secs, seconds, mins, minutes, hours, days, weeks, months,
#' quarters, and years.
#'
#' The 'period' portion can be any frequency greater than or equal to the
#' frequency of the object's time index. For example, `first(x, "2 months")`
#' will return the first 2 months of data even if `x` is hourly frequency.
#' Attempts to set 'period' to a frequency less than the object's frequency
#' will throw an error.
#'
#' `n` may be positive or negative, whether it's a number or character string.
#' When `n` is positive, the functions return the obvious result. For example,
#' `first(x, "1 month")` returns the first month's data. When `n` is negative,
#' all data *except* first month's is returned.
#'
#' Requesting more data than is in `x` will throw a warning and simply return
#' `x`.
#'
#' @param x An object.
#' @param n Number of observations to return.
#' @param keep Should removed values be kept as an attribute on the result?
#' @param \dots Arguments passed to other methods.
#'
#' @return A subset of elements/rows of the original data.
#'
#' @author Jeffrey A. Ryan
#'
#' @keywords utilities
#' @examples
#'
#' first(1:100)
#' last(1:100)
#'
#' data(LakeHuron)
#' first(LakeHuron,10)
#' last(LakeHuron)
#'
#' x <- xts(1:100, Sys.Date()+1:100)
#' first(x, 10)
#' first(x, '1 day')
#' first(x, '4 days')
#' first(x, 'month')
#' last(x, '2 months')
#' last(x, '6 weeks')
#'
`first` <-
function(x,...)
{
UseMethod("first")
}
#' @rdname first
`first.default` <-
function(x,n=1,keep=FALSE,...)
{
if(length(x) == 0)
return(x)
if(is.character(n)) {
xx <- try.xts(x, error=FALSE)
if(is.xts(xx)) {
xx <- first.xts(x, n=n, keep=keep, ...)
return(reclass(xx))
}
}
if(is.null(dim(x))) {
if(n > 0) {
sub <- seq_len(min(n, length(x)))
xx <- x[sub]
if(keep) xx <- structure(xx,keep=x[(-(-n)+1):NROW(x)])
xx
} else if(n < 0) {
sub <- seq.int(to = length(x), length.out = max(length(x)-(-n), 0L))
xx <- x[sub]
if(keep) xx <- structure(xx,keep=x[1:(-n)])
xx
} else {
xx <- x[0]
if(keep) xx <- structure(xx,keep=x[0])
xx
}
} else {
if(n > 0) {
sub <- seq_len(min(n, NROW(x)))
xx <- x[sub,,drop=FALSE]
if(keep) xx <- structure(xx,keep=x[(-(-n)+1):NROW(x),])
xx
} else if(n < 0) {
sub <- seq.int(to = NROW(x), length.out = max(NROW(x)-(-n), 0L))
xx <- x[sub,,drop=FALSE]
if(keep) xx <- structure(xx,keep=x[1:(-n),])
xx
} else {
xx <- x[0,,drop=FALSE]
if(keep) xx <- structure(xx,keep=x[0,])
xx
}
}
}
#' @rdname first
`first.xts` <-
function(x,n=1,keep=FALSE,...)
{
if(length(x) == 0)
return(x)
if(is.character(n)) {
# n period set
np <- strsplit(n," ",fixed=TRUE)[[1]]
if(length(np) > 2 || length(np) < 1)
stop(paste("incorrectly specified",sQuote("n"),sep=" "))
# series periodicity
sp <- periodicity(x)
# requested periodicity$units
sp.units <- sp[["units"]]
rpu <- np[length(np)]
rpf <- ifelse(length(np) > 1, as.numeric(np[1]), 1)
if(rpu == sp.units) {
n <- rpf
} else {
# if singular - add an s to make it work
if(substr(rpu,length(strsplit(rpu,'')[[1]]),length(strsplit(rpu,'')[[1]])) != 's')
rpu <- paste(rpu,'s',sep='')
u.list <- list(secs=4,seconds=4,mins=3,minutes=3,hours=2,days=1,
weeks=1,months=1,quarters=1,years=1)
dt.options <- c('seconds','secs','minutes','mins','hours','days',
'weeks','months','quarters','years')
if(!rpu %in% dt.options)
stop(paste("n must be numeric or use",paste(dt.options,collapse=',')))
dt <- dt.options[pmatch(rpu,dt.options)]
if(u.list[[dt]] > u.list[[sp.units]]) {
# req is for higher freq data period e.g. 100 mins of daily data
stop(paste("At present, without some sort of magic, it isn't possible",
"to resolve",rpu,"from",sp$scale,"data"))
}
ep <- endpoints(x,dt)
if(rpf > length(ep)-1) {
rpf <- length(ep)-1
warning("requested length is greater than original")
}
if(rpf > 0) {
n <- ep[rpf+1]
if(is.null(dim(x))) {
xx <- x[1:n]
} else {
xx <- x[1:n,,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[(ep[-(-rpf)+1]+1):NROW(x)])
return(xx)
} else if(rpf < 0) {
n <- ep[-rpf+1]+1
if(is.null(dim(x))) {
xx <- x[n:NROW(x)]
} else {
xx <- x[n:NROW(x),,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[1:(ep[-rpf+1])])
return(xx)
} else {
if(is.null(dim(x))) {
xx <- x[0]
} else {
xx <- x[0,,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[0])
return(xx)
}
}
}
if(length(n) != 1) stop("n must be of length 1")
if(n > 0) {
n <- min(n, NROW(x))
if(is.null(dim(x))) {
xx <- x[1:n]
} else {
xx <- x[1:n,,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[(-(-n)+1):NROW(x)])
xx
} else if(n < 0) {
if(abs(n) >= NROW(x))
return(x[0])
if(is.null(dim(x))) {
xx <- x[(-n+1):NROW(x)]
} else {
xx <- x[(-n+1):NROW(x),,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[1:(-n)])
xx
} else {
if(is.null(dim(x))) {
xx <- x[0]
} else {
xx <- x[0,,drop=FALSE]
}
if(keep) xx <- structure(xx,keep=x[0])
xx
}
}
xts/R/na.R 0000644 0001762 0000144 00000011212 14654242576 012026 0 ustar ligges users #
# 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 2 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 .
na.omit.xts <- function(object, ...) {
xx <- .Call(C_na_omit_xts, object)
if(length(xx)==0)
return(structure(xts(,),.Dim=c(0,NCOL(object))))
naa <- attr(xx,'na.action')
if(length(naa) == 0)
return(xx)
naa.index <- .index(object)[naa]
ROWNAMES <- attr(object,'.ROWNAMES')
if(!is.null(ROWNAMES)) {
naa.rownames <- ROWNAMES[naa]
} else naa.rownames <- NULL
attr(xx,'na.action') <- structure(naa,
index=naa.index,
.ROWNAMES=naa.rownames)
return(xx)
}
na.exclude.xts <- function(object, ...) {
xx <- .Call(C_na_omit_xts, object)
naa <- attr(xx,'na.action')
if(length(naa) == 0)
return(xx)
naa.index <- .index(object)[naa]
ROWNAMES <- attr(object,'.ROWNAMES')
if(!is.null(ROWNAMES)) {
naa.rownames <- ROWNAMES[naa]
} else naa.rownames <- NULL
attr(xx,'na.action') <- structure(naa,
class="exclude",
index=naa.index,
.ROWNAMES=naa.rownames)
return(xx)
}
na.restore <- function(object, ...) {
UseMethod("na.restore")
}
na.restore.xts <- function(object, ...) {
if(is.null(na.action(object)))
return(object)
structure(merge(structure(object,na.action=NULL),
.xts(,attr(na.action(object),"index"))),
.Dimnames=list(NULL, colnames(object)))
}
na.replace <- function(x) {
.Deprecated("na.restore")
if(is.null(xtsAttributes(x)$na.action))
return(x)
# Create 'NA' xts object
tmp <- xts(matrix(rep(NA,NCOL(x)*NROW(x)), ncol=NCOL(x)),
attr(xtsAttributes(x)$na.action, 'index'))
# Ensure xts 'NA' object has *all* the same attributes
# as the object 'x'; this is necessary for rbind to
# work correctly
CLASS(tmp) <- CLASS(x)
xtsAttributes(tmp) <- xtsAttributes(x)
attr(x,'na.action') <- attr(tmp,'na.action') <- NULL
colnames(tmp) <- colnames(x)
rbind(x,tmp)
}
#' Last Observation Carried Forward
#'
#' \pkg{xts} method replace `NA` with most recent non-NA
#'
#' This is the \pkg{xts} method for the S3 generic `na.locf()`. The primary
#' difference to note is that after the `NA` fill action is carried out, the
#' default it to leave trailing or leading `NA`'s in place. This is different
#' than \pkg{zoo} behavior.
#'
#' @param object An xts object.
#' @param na.rm Logical indicating whether leading/trailing `NA` should be
#' removed. The default is `FALSE` unlike the zoo method.
#' @param fromLast Logical indicating whether observations should be carried
#' backward rather than forward. Default is `FALSE`.
#' @param maxgap Consecutive runs of observations more than 'maxgap' will
#' remain `NA`. See [`na.locf()`][zoo::zoo] for details.
#' @param \dots Unused.
#'
#' @return An object where each `NA` in `object` is replaced by the most recent
#' non-NA prior to it. See [`na.locf()`][zoo::zoo] for details.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`na.locf()`][zoo::zoo]
#'
#' @keywords misc
#' @examples
#'
#' x <- xts(1:10, Sys.Date()+1:10)
#' x[c(1,2,5,9,10)] <- NA
#'
#' x
#' na.locf(x)
#' na.locf(x, fromLast=TRUE)
#' na.locf(x, na.rm=TRUE, fromLast=TRUE)
#'
na.locf.xts <- function(object, na.rm=FALSE, fromLast=FALSE, maxgap=Inf, ...) {
maxgap <- min(maxgap, NROW(object))
if(length(object) == 0)
return(object)
if(hasArg("x") || hasArg("xout"))
return(NextMethod(.Generic))
x <- .Call(C_na_locf, object, fromLast, maxgap, Inf)
if(na.rm) {
return(structure(na.omit(x),na.action=NULL))
} else x
}
na.fill.xts <- function(object, fill, ix, ...) {
if (length(fill) == 1 && missing(ix)) {
# na.fill0() may change the storage type of 'object'
# make sure 'fill' argument is same type as 'object'
fill. <- fill
storage.mode(fill.) <- storage.mode(object)
return(na.fill0(object, fill.))
} else {
NextMethod(.Generic)
}
}
xts/R/ts.R 0000644 0001762 0000144 00000007137 14654242576 012071 0 ustar ligges users #
# 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 2 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 .
# methods for handling ts <--> xts
`re.ts` <-
function(x,...) {
# major issue with quick reclass. Basically fails on data < 1970...
#tsp.attr <- attr(x,'.tsp')
#freq.attr <- attr(x,'.frequency')
#xtsAttributes(x) <- NULL
#ts(coredata(x), start=tsp.attr[1],frequency=freq.attr)
dim <- attr(x, 'dim')
if(!is.null(dim) && dim[2]==1) {
attr(x,'dim') <- attr(x, 'dimnames') <- NULL
}
as.ts(x)
}
#' @rdname as.xts
`as.xts.ts` <-
function(x,dateFormat,...,.RECLASS=FALSE) {
x.mat <- structure(as.matrix(x),dimnames=dimnames(x))
colnames(x.mat) <- colnames(x)
# quick hueristic - if numeric index is larger than one
# full day of seconds (60*60*24) than use POSIXct, otherwise
# assume we are counting my days, not seconds, and use Date -jar
#
# I am sure this can be improved upon, but for now it is effective
# in most circumstances. Will break if frequency or time is from 1
# not _break_ but be less useful
# a bigger question is _should_ it throw an error if it can't guess,
# or should the user simply beware.
if(missing(dateFormat)) {
if(frequency(x) == 1) {
# assume yearly series: Date
yr <- tsp(x)[1] %/% 1
mo <- tsp(x)[1] %% 1
if(mo %% (1/12) != 0 || yr > 3000) {
# something finer than year.month is specified - can't reliable convert
dateFormat <- ifelse(max(time(x)) > 86400,'POSIXct','Date')
order.by <- do.call(paste('as',dateFormat,sep='.'),
list(as.numeric(time(x)),origin='1970-01-01',...))
} else {
mo <- ifelse(length(mo) < 1, 1,floor(mo * 12)+1)
from <- as.Date(firstof(yr,mo),origin='1970-01-01')
order.by <- seq.Date(from,length.out=length(time(x)),by='year')
}
} else
if(frequency(x) == 4) {
# quarterly series: yearqtr
order.by <- as.yearqtr(time(x))
} else
if(frequency(x) == 12) {
# monthly series: yearmon
order.by <- as.yearmon(time(x))
} else stop('could not convert index to appropriate type')
} else {
order.by <- do.call(paste('as',dateFormat,sep='.'),
list(as.numeric(time(x)),...))
}
if(.RECLASS) {
xx <- xts(x.mat,
order.by=order.by,
frequency=frequency(x),
.CLASS='ts',
.CLASSnames=c('frequency'),
.tsp=tsp(x),
# .frequency=frequency(x),
...)
} else {
xx <- xts(x.mat,
order.by=order.by,
frequency=frequency(x),
...)
}
attr(xx, 'tsp') <- NULL
xx
}
`as.ts.xts` <-
function(x,...) {
#if(attr(x,'.CLASS')=='ts') return(re.ts(x,...))
TSP <- attr(x, '.tsp')
attr(x, '.tsp') <- NULL
x <- ts(coredata(x), frequency=frequency(x), ...)
if(!is.null(dim(x)) && dim(x)[2]==1)
dim(x) <- NULL
if(!is.null(TSP))
tsp(x) <- TSP
x
}
xts/R/xts.methods.R 0000644 0001762 0000144 00000051162 14654242576 013720 0 ustar ligges users #
# xts: eXtensible time-series
#
# Copyright (C) 2008 Jeffrey A. Ryan jeff.a.ryan @ gmail.com
#
# Contributions from Joshua M. Ulrich
# window.xts contributed by Corwin Joy
#
# 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 2 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 .
.subsetTimeOfDay <- function(x, fromTimeString, toTimeString) {
validateTimestring <- function(time) {
h <- "(?:[01]?\\d|2[0-3])"
hm <- paste0(h, "(?::?[0-5]\\d)")
hms <- paste0(hm, "(?::?[0-5]\\d)")
hmsS <- paste0(hms, "(?:\\.\\d{1,9})?")
pattern <- paste(h, hm, hms, hmsS, sep = ")$|^(")
pattern <- paste0("^(", pattern, "$)")
if (!grepl(pattern, time)) {
# FIXME: this isn't necessarily true...
# colons aren't required, and neither are all of the components
stop("Supply time-of-day subsetting in the format of T%H:%M:%OS/T%H:%M:%OS",
call. = FALSE)
}
}
validateTimestring(fromTimeString)
validateTimestring(toTimeString)
getTimeComponents <- function(time) {
# split on decimal point
time. <- strsplit(time, ".", fixed = TRUE)[[1]]
hms <- time.[1L]
# ensure hms string has even nchar
nocolon <- gsub(":", "", hms, fixed = TRUE)
if (nchar(nocolon) %% 2 > 0) {
# odd nchar means leading zero is omitted from hours
# all other components require zero padding
hms <- paste0("0", hms)
}
# add colons
hms <- gsub("(.{2}):?", ":\\1", hms, perl = TRUE)
# remove first character (a colon)
hms <- substr(hms, 2, nchar(hms))
# extract components
comp <- strsplit(hms, ":", fixed = TRUE)[[1]]
complist <-
list(hour = comp[1L],
min = comp[2L],
sec = comp[3L],
subsec = time.[2L])
# remove all missing components
complist <- complist[!vapply(complist, is.na, logical(1))]
# convert to numeric
complist <- lapply(complist, as.numeric)
# add timezone and return
c(tz = "UTC", complist)
}
# first second in period (no subseconds)
from <- do.call(firstof, getTimeComponents(fromTimeString)[-5L])
secBegin <- as.numeric(from) %% 86400L
# last second in period
to <- do.call(lastof, getTimeComponents(toTimeString))
secEnd <- as.numeric(to) %% 86400L
# do subsetting
tz <- tzone(x)
secOfDay <- as.POSIXlt(index(x), tz = tz)
secOfDay <- secOfDay$hour * 60 * 60 + secOfDay$min * 60 + secOfDay$sec
if (secBegin <= secEnd) {
i <- secOfDay >= secBegin & secOfDay <= secEnd
} else {
i <- secOfDay >= secBegin | secOfDay <= secEnd
}
which(i)
}
.subset_xts <- function(x, i, j, ...) {
if(missing(i)) {
i <- 1:NROW(x)
}
if(missing(j)) {
j <- 1:NCOL(x)
}
.Call(C__do_subset_xts, x, i, j, FALSE)
}
#' Extract Subsets of xts Objects
#'
#' Details on efficient subsetting of xts objects for maximum performance
#' and compatibility.
#'
#' One of the primary motivations and key points of differentiation of xts is
#' the ability to subset rows by specifying ISO-8601 compatible range strings.
#' This allows for natural range-based time queries without requiring prior
#' knowledge of the underlying class used for the time index.
#'
#' When `i` is a character string, it is processed as an ISO-8601 formatted
#' datetime or time range using [`.parseISO8601()`]. A single datetime is
#' parsed from left to to right, according to the following specification:
#'
#' CCYYMMDD HH:MM:SS.ss+
#'
#' A time range can be specified by two datetimes separated by a forward slash
#' or double-colon. For example:
#'
#' CCYYMMDD HH:MM:SS.ss+/CCYYMMDD HH:MM:SS.ss
#'
#' The ISO8601 time range subsetting uses a custom binary search algorithm to
#' efficiently find the beginning and end of the time range. `i` can also be a
#' vector of ISO8601 time ranges, which enables subsetting by multiple
#' non-contiguous time ranges in one subset call.
#'
#' The above parsing, both for single datetimes and time ranges, will be done
#' on each element when `i` is a character *vector*. This is very inefficient,
#' especially for long vectors. In this case, it's recommened to use `I(i)` so
#' the xts subset function can process the vector more efficiently. Another
#' alternative is to convert `i` to POSIXct before passing it to the subset
#' function. See the examples for an illustration of using `I(i)`.
#'
#' The xts index is stored as POSIXct internally, regardless of the value of
#' its `tclass` attribute. So the fastest time-based subsetting is always when
#' `i` is a POSIXct vector.
#'
#' @param x An xts object.
#' @param i The rows to extract. Can be a numeric vector, time-based vector, or
#' an ISO-8601 style range string (see details).
#' @param j The columns to extract, either a numeric vector of column locations
#' or a character vector of column names.
#' @param drop Should dimension be dropped, if possible? See notes section.
#' @param which.i Logical value that determines whether a subset xts object is
#' returned (the default), or the locations of the matching rows (when
#' `which.i = TRUE`).
#' @param \dots Additional arguments (currently unused).
#'
#' @return An xts object containing the subset of `x`. When `which.i = TRUE`,
#' the corresponding integer locations of the matching rows is returned.
#'
#' @note By design, xts objects always have two dimensions. They cannot be
#' vectors like zoo objects. Therefore `drop = FALSE` by default in order to
#' preserve the xts object's dimensions. This is different from both matrix and
#' zoo, which use `drop = TRUE` by default. Explicitly setting `drop = TRUE`
#' may be needed when performing certain matrix operations.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`xts()`], [`.parseISO8601()`], [`.index()`]
#'
#' @references ISO 8601: Date elements and interchange formats - Information
#' interchange - Representation of dates and time
#'
#' @rdname subset.xts
#'
#' @aliases [.xts subset.xts .subset.xts .subset_xts
#' @keywords utilities
#' @examples
#'
#' x <- xts(1:3, Sys.Date()+1:3)
#' xx <- cbind(x,x)
#'
#' # drop = FALSE for xts, differs from zoo and matrix
#' z <- as.zoo(xx)
#' z/z[,1]
#'
#' m <- as.matrix(xx)
#' m/m[,1]
#'
#' # this will fail with non-conformable arrays (both retain dim)
#' tryCatch(
#' xx/x[,1],
#' error = function(e) print("need to set drop = TRUE")
#' )
#'
#' # correct way
#' xx/xx[,1,drop = TRUE]
#'
#' # or less efficiently
#' xx/drop(xx[,1])
#' # likewise
#' xx/coredata(xx)[,1]
#'
#'
#' x <- xts(1:1000, as.Date("2000-01-01")+1:1000)
#' y <- xts(1:1000, as.POSIXct(format(as.Date("2000-01-01")+1:1000)))
#'
#' x.subset <- index(x)[1:20]
#' x[x.subset] # by original index type
#' system.time(x[x.subset])
#' x[as.character(x.subset)] # by character string. Beware!
#' system.time(x[as.character(x.subset)]) # slow!
#' system.time(x[I(as.character(x.subset))]) # wrapped with I(), faster!
#'
#' x['200001'] # January 2000
#' x['1999/2000'] # All of 2000 (note there is no need to use the exact start)
#' x['1999/200001'] # January 2000
#'
#' x['2000/200005'] # 2000-01 to 2000-05
#' x['2000/2000-04-01'] # through April 01, 2000
#' y['2000/2000-04-01'] # through April 01, 2000 (using POSIXct series)
#'
#'
#' ### Time of day subsetting
#'
#' i <- 0:60000
#' focal_date <- as.numeric(as.POSIXct("2018-02-01", tz = "UTC"))
#' x <- .xts(i, c(focal_date + i * 15), tz = "UTC", dimnames = list(NULL, "value"))
#'
#' # Select all observations between 9am and 15:59:59.99999:
#' w1 <- x["T09/T15"] # or x["T9/T15"]
#' head(w1)
#'
#' # timestring is of the form THH:MM:SS.ss/THH:MM:SS.ss
#'
#' # Select all observations between 13:00:00 and 13:59:59.9999 in two ways:
#' y1 <- x["T13/T13"]
#' head(y1)
#'
#' x[.indexhour(x) == 13]
#'
#' # Select all observations between 9:30am and 30 seconds, and 4.10pm:
#' x["T09:30:30/T16:10"]
#'
#' # It is possible to subset time of day overnight.
#' # e.g. This is useful for subsetting FX time series which trade 24 hours on week days
#'
#' # Select all observations between 23:50 and 00:15 the following day, in the xts time zone
#' z <- x["T23:50/T00:14"]
#' z["2018-02-10 12:00/"] # check the last day
#'
#'
#' # Select all observations between 7pm and 8.30am the following day:
#' z2 <- x["T19:00/T08:29:59"]
#' head(z2); tail(z2)
#'
`[.xts` <-
function(x, i, j, drop = FALSE, which.i=FALSE,...)
{
USE_EXTRACT <- FALSE # initialize to FALSE
dimx <- dim(x)
if(is.null(dimx)) {
nr <- length(x)
if(nr==0 && !which.i) {
idx <- index(x)
if(length(idx) == 0) {
# this is an empty xts object (zero-length index and no columns)
# return it unchanged to match [.zoo
return(x)
} else {
return(xts(rep(NA, length(idx)), idx)[i])
}
}
nr <- length(.index(x))
nc <- 1L
} else {
nr <- dimx[1L]
nc <- dimx[2L]
}
if(!missing(i)) {
# test for negative subscripting in i
if (is.numeric(i)) {
# warn and convert if 'i' is not integer-like
i_int <- as.integer(i)
i_eps <- abs(i) - abs(i_int)
if (isTRUE(any(i_eps > sqrt(.Machine$double.eps)))) {
warning("converting 'i' to integer because it appears to contain fractions")
i <- i_int
}
#if(any(i < 0)) {
if(.Call(C_any_negative, i)) {
if(!all(i <= 0))
stop('only zeros may be mixed with negative subscripts')
i <- (1:nr)[i]
}
# check boundary; length check avoids Warning from max(), and
# any_negative ensures no NA (as of r608)
#if(max(i) > nr)
if(length(i) > 0 && max(i) > nr)
stop('subscript out of bounds')
#i <- i[-which(i == 0)]
} else
if (timeBased(i) || (inherits(i, "AsIs") && is.character(i)) ) {
# Fast binary search on set of dates
i <- window_idx(x, index. = i)
} else
if(is.logical(i)) {
i <- which(i) #(1:NROW(x))[rep(i,length.out=NROW(x))]
} else
if (is.character(i)) {
time.of.day.pattern <- "(^/T)|(^T.*?/T)|(^T.*/$)"
if (length(i) == 1 && !identical(integer(), grep(time.of.day.pattern, i[1]))) {
# time of day subsetting
ii <- gsub("T", "", i, fixed = TRUE)
ii <- strsplit(ii, "/", fixed = TRUE)[[1L]]
if (length(ii) == 1) {
# i is right open ended (T.*/)
ii <- c(ii, "23:59:59.999999999")
} else if (nchar(ii[1L]) == 0) {
# i is left open ended (/T)
ii[1L] <- "00:00:00.000000000"
} # else i is bounded on both sides (T.*/T.*)
i <- .subsetTimeOfDay(x, ii[1L], ii[2L])
} else {
# enables subsetting by date style strings
# must be able to process - and then allow for operations???
i.tmp <- NULL
tz <- as.character(tzone(x))
for(ii in i) {
adjusted.times <- .parseISO8601(ii, .index(x)[1], .index(x)[nr], tz=tz)
if(length(adjusted.times) > 1) {
i.tmp <- c(i.tmp, index_bsearch(.index(x), adjusted.times$first.time, adjusted.times$last.time))
}
}
i <- i.tmp
}
i_len <- length(i)
if(i_len == 1L) # IFF we are using ISO8601 subsetting
USE_EXTRACT <- TRUE
}
if(!isOrdered(i,strictly=FALSE)) {
i <- sort(i)
}
# subset is picky, 0's in the 'i' position cause failures
zero.index <- binsearch(0L, i, FALSE)
if(!is.na(zero.index)) {
# at least one 0; binsearch returns location of last 0
i <- i[-(1L:zero.index)]
}
if(length(i) <= 0 && USE_EXTRACT)
USE_EXTRACT <- FALSE
if(which.i)
return(i)
} # if(!missing(i)) { end
if (missing(j)) {
if(missing(i))
i <- seq_len(nr)
if(length(x)==0) {
cdata <- rep(NA, length(i))
storage.mode(cdata) <- storage.mode(x)
x.tmp <- .xts(cdata, .index(x)[i], tclass(x), tzone(x),
dimnames = list(NULL, colnames(x)))
return(x.tmp)
} else {
if(USE_EXTRACT) {
return(.Call(C_extract_col,
x, as.integer(1:nc),
drop,
as.integer(i[1]), as.integer(i[length(i)])))
} else {
return(.Call(C__do_subset_xts,
x, as.integer(i),
as.integer(1:nc),
drop))
}
}
} else
# test for negative subscripting in j
if (is.numeric(j)) {
# warn and convert if 'j' is not integer-like
j_int <- as.integer(j)
j_eps <- abs(j) - abs(j_int)
if (isTRUE(any(j_eps > sqrt(.Machine$double.eps)))) {
warning("converting 'j' to integer because it appears to contain fractions")
j <- j_int
}
if(min(j,na.rm=TRUE) < 0) {
if(max(j,na.rm=TRUE) > 0)
stop('only zeros may be mixed with negative subscripts')
j <- (1:nc)[j]
}
if(max(j,na.rm=TRUE) > nc)
stop('subscript out of bounds')
} else
if(is.logical(j)) {
if(length(j) == 1) {
j <- (1:nc)[rep(j, nc)]
}
else if (length(j) > nc) {
stop("(subscript) logical subscript too long")
} else j <- (1:nc)[j]
} else
if(is.character(j)) {
j <- match(j, colnames(x), nomatch=0L)
# ensure all j are in colnames(x)
if(any(j==0))
stop("subscript out of bounds")
}
j0 <- which(!as.logical(j))
if(length(j0))
j <- j[-j0]
if(length(j) == 0 || (length(j)==1 && (is.na(j) || j==0))) {
if(missing(i))
i <- seq_len(nr)
output <- .xts(coredata(x)[i,j,drop=FALSE], .index(x)[i],
tclass(x), tzone(x), class = class(x))
xtsAttributes(output) <- xtsAttributes(x)
return(output)
}
if(missing(i))
return(.Call(C_extract_col, x, as.integer(j), drop, 1, nr))
if(USE_EXTRACT) {
return(.Call(C_extract_col,
x, as.integer(j),
drop,
as.integer(i[1]), as.integer(i[length(i)])))
} else
return(.Call(C__do_subset_xts, x, as.integer(i), as.integer(j), drop))
}
`.subset.xts` <- `[.xts`
# Replacement method for xts objects
#
# Adapted from [.xts code, making use of NextGeneric as
# replacement function in R already preserves all attributes
# and index value is left untouched
`[<-.xts` <-
#`xtsreplacement` <-
function(x, i, j, value)
{
if (!missing(i)) {
i <- x[i, which.i=TRUE]
}
.Class <- "matrix"
NextMethod(.Generic)
}
# Convert a character or time type to POSIXct for use by subsetting and window
# We make this an explicit function so that subset and window will convert dates consistently.
.toPOSIXct <-
function(i, tz) {
if(inherits(i, "POSIXct")) {
dts <- i
} else if(is.character(i)) {
dts <- as.POSIXct(as.character(i),tz=tz) # Need as.character because i could be AsIs from I(dates)
} else if (timeBased(i)) {
if(inherits(i, "Date")) {
dts <- as.POSIXct(as.character(i),tz=tz)
} else {
# force all other time classes to be POSIXct
dts <- as.POSIXct(i,tz=tz)
}
} else {
stop("invalid time / time based class")
}
dts
}
# find the rows of index. where the date is in [start, end].
# use binary search.
# convention is that NA start or end returns empty
index_bsearch <- function(index., start, end)
{
if(!is.null(start) && is.na(start)) return(NULL)
if(!is.null(end) && is.na(end)) return(NULL)
if(is.null(start)) {
si <- 1
} else {
si <- binsearch(start, index., TRUE)
}
if(is.null(end)) {
ei <- length(index.)
} else {
ei <- binsearch(end, index., FALSE)
}
if(is.na(si) || is.na(ei) || si > ei) return(NULL)
firstlast <- seq.int(si, ei)
firstlast
}
# window function for xts series
# return indexes in x matching dates
window_idx <- function(x, index. = NULL, start = NULL, end = NULL)
{
if(is.null(index.)) {
usr_idx <- FALSE
index. <- .index(x)
} else {
# Translate the user index to the xts index
usr_idx <- TRUE
idx <- .index(x)
index. <- .toPOSIXct(index., tzone(x))
index. <- unclass(index.)
index. <- index.[!is.na(index.)]
if(is.unsorted(index.)) {
# index. must be sorted for index_bsearch
# N.B!! This forces the returned values to be in ascending time order, regardless of the ordering in index, as is done in subset.xts.
index. <- sort(index.)
}
# Fast search on index., faster than binsearch if index. is sorted (see findInterval)
base_idx <- findInterval(index., idx)
base_idx <- pmax(base_idx, 1L)
# Only include indexes where we have an exact match in the xts series
match <- idx[base_idx] == index.
base_idx <- base_idx[match]
index. <- index.[match]
index. <- .POSIXct(index., tz = tzone(x))
if(length(base_idx) < 1) return(x[NULL,])
}
if(!is.null(start)) {
start <- .toPOSIXct(start, tzone(x))
}
if(!is.null(end)) {
end <- .toPOSIXct(end, tzone(x))
}
firstlast <- index_bsearch(index., start, end)
if(usr_idx && !is.null(firstlast)) {
# Translate from user .index to xts index
# We get back upper bound of index as per findInterval
tmp <- base_idx[firstlast]
res <- .Call(C_fill_window_dups_rev, tmp, .index(x))
firstlast <- rev(res)
}
firstlast
}
# window function for xts series, use binary search to be faster than base zoo function
# index. defaults to the xts time index. If you use something else, it must conform to the standard for order.by in the xts constructor.
# that is, index. must be time based,
#' Extract Time Windows from xts Objects
#'
#' Method for extracting time windows from xts objects.
#'
#' The xts `window()` method provides an efficient way to subset an xts object
#' between a start and end date using a binary search algorithm. Specifically,
#' it converts `start` and `end` to POSIXct and then does a binary search of
#' the index to quickly return a subset of `x` between `start` and `end`.
#'
#' Both `start` and `end` may be any class that is convertible to POSIXct, such
#' as a character string in the format \sQuote{yyyy-mm-dd}. When `start = NULL`
#' the returned subset will begin at the first value of `index.`. When
#' `end = NULL` the returned subset will end with the last value of `index.`.
#' Otherwise the subset will contain all timestamps where `index.` is between
#' `start` and `end`, inclusive.
#'
#' When `index.` is specified, [`findInterval()`] is used to quickly retrieve
#' large sets of sorted timestamps. For the best performance, `index.` must be
#' a *sorted* POSIXct vector or a numeric vector of seconds since the epoch.
#' `index.` is typically a subset of the timestamps in `x`.
#'
#' @param x An xts object.
#' @param index. A user defined time index (default `.index(x)`).
#' @param start A start time coercible to POSIXct.
#' @param end An end time coercible to POSIXct.
#' @param \dots Unused.
#'
#' @return The subset of `x` that matches the time window.
#'
#' @author Corwin Joy
#'
#' @seealso [`subset.xts()`], [`findInterval()`], [`xts()`]
#'
#' @keywords ts
#' @examples
#'
#' ## xts example
#' x.date <- as.Date(paste(2003, rep(1:4, 4:1), seq(1,19,2), sep = "-"))
#' x <- xts(matrix(rnorm(20), ncol = 2), x.date)
#' x
#'
#' window(x, start = "2003-02-01", end = "2003-03-01")
#' window(x, start = as.Date("2003-02-01"), end = as.Date("2003-03-01"))
#' window(x, index. = x.date[1:6], start = as.Date("2003-02-01"))
#' window(x, index. = x.date[c(4, 8, 10)])
#'
#' ## Assign to subset
#' window(x, index. = x.date[c(4, 8, 10)]) <- matrix(1:6, ncol = 2)
#' x
#'
window.xts <- function(x, index. = NULL, start = NULL, end = NULL, ...)
{
# scalar NA values are treated as NULL
if (isTRUE(is.na(start))) start <- NULL
if (isTRUE(is.na(end))) end <- NULL
if(is.null(start) && is.null(end) && is.null(index.)) return(x)
# dispatch to window.zoo() for yearmon and yearqtr
if(any(tclass(x) %in% c("yearmon", "yearqtr"))) {
return(NextMethod(.Generic))
}
firstlast <- window_idx(x, index., start, end) # firstlast may be NULL
.Call(C__do_subset_xts,
x, as.integer(firstlast),
seq.int(1, ncol(x)),
drop = FALSE)
}
# Declare binsearch to call the routine in binsearch.c
binsearch <- function(key, vec, start=TRUE) {
# Convert to double if both are not integer
if (storage.mode(key) != storage.mode(vec)) {
storage.mode(key) <- storage.mode(vec) <- "double"
}
.Call(C_binsearch, key, vec, start)
}
xts/R/tformat.R 0000644 0001762 0000144 00000006206 14702273713 013102 0 ustar ligges users #
# 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 2 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 .
#' Get or Replace the Format of an xts Object's Index
#'
#' Generic functions to get or replace the format that determines how an xts
#' object's index is printed.
#'
#' Valid values for the `value` argument are the same as specified in the
#' *Details* section of [`strptime()`].
#'
#' An xts object's `tformat` is `NULL` by default, so the index will be
#' be formatted according to its [`tclass()`] (e.g. Date, POSIXct, timeDate,
#' yearmon, etc.).
#'
#' The `tformat` only changes how the index is *printed* and how the row names
#' are formatted when xts objects are converted to other classes (e.g. matrix
#' or data.frame). It does not affect the internal index in any way.
#'
#' @param x An xts object.
#' @param value New index format string (see [`strptime()`] details for valid
#' values).
#' @param \dots Arguments passed to other methods.
#'
#' @return A vector containing the format for the object's index.
#'
#' @note Both `indexFormat()` and `indexFormat<-` are deprecated in
#' favor of `tformat()` and `tformat<-`, respectively.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`index()`][xts::index.xts] has more information on the xts index, [`tclass()`]
#' details how \pkg{xts} handles the class of the index, [`tzone()`] has more
#' information about the index timezone settings.
#'
#' @keywords ts utilities
#' @examples
#'
#' x <- timeBasedSeq('2010-01-01/2010-01-02 12:00')
#' x <- xts(seq_along(x), x)
#'
#' # set a custom index format
#' head(x)
#' tformat(x) <- "%Y-%b-%d %H:%M:%OS3"
#' head(x)
#'
`tformat` <-
function(x, ...) {
UseMethod('tformat')
}
#' @rdname tformat
`tformat<-` <-
function(x, value) {
UseMethod('tformat<-')
}
`tformat.default` <-
function(x, ...) {
attr(x, 'tformat')
}
`tormat<-.default` <-
function(x, value) {
attr(x, '.tformat') <- value
x
}
`tformat.xts` <-
function(x, ...) {
ix <- .index(x)
attr(ix, 'tformat')
}
`tformat<-.xts` <-
function(x, value) {
if(!is.character(value) && !is.null(value))
stop('must provide valid POSIX formatting string')
# Remove format attrs (object created before 0.10-3)
attr(x, ".indexFORMAT") <- NULL
attr(attr(x, 'index'), 'tformat') <- value
x
}
#' @rdname tformat
`indexFormat` <-
function(x) {
.Deprecated("tformat", "xts")
tformat(x)
}
#' @rdname tformat
`indexFormat<-` <-
function(x, value) {
.Deprecated("tformat<-", "xts")
`tformat<-`(x, value)
}
xts/R/bind.R 0000644 0001762 0000144 00000005420 14654242576 012350 0 ustar ligges users #
# 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 2 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 .
#' @rdname rbind.xts
`c.xts` <-
function(...) {
.External(C_rbindXts, dup=FALSE, ...)
}
#' Concatenate Two or More xts Objects by Row
#'
#' Concatenate or bind by row two or more xts objects along a time-based index.
#' All objects must have the same number of columns and be xts objects or
#' coercible to xts.
#'
#' Duplicate index values are supported. When one or more input has the same
#' index value, the duplicated index values in the result are in the same order
#' the objects are passed to `rbind()`. See examples.
#'
#' `c()` is an alias for `rbind()` for xts objects.
#'
#' See [`merge.xts()`] for traditional merge operations.
#'
#' @param \dots Objects to bind by row.
#' @param deparse.level Not implemented.
#'
#' @return An xts object with one row per row for each object concatenated.
#'
#' @note `rbind()` is a '.Primitive' function in \R, which means method dispatch
#' occurs at the C-level, and may not be consistent with normal S3 method
#' dispatch (see [`rbind()`] for details). Call `rbind.xts()` directly to
#' avoid potential dispatch ambiguity.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`merge.xts()`] [`rbind()`]
#'
#' @keywords utilities
#' @examples
#'
#' x <- xts(1:10, Sys.Date()+1:10)
#' str(x)
#'
#' merge(x,x)
#' rbind(x,x)
#' rbind(x[1:5],x[6:10])
#'
#' c(x,x)
#'
#' # this also works on non-unique index values
#' x <- xts(rep(1,5), Sys.Date()+c(1,2,2,2,3))
#' y <- xts(rep(2,3), Sys.Date()+c(1,2,3))
#'
#' # overlapping indexes are appended
#' rbind(x,y)
#' rbind(y,x)
#'
rbind.xts <- function(..., deparse.level=1)
{
.External(C_rbindXts, dup=FALSE, ...)
}
`.rbind.xts` <-
function(..., deparse.level=1) {
dots <- list(...)
if(length(dots) < 2) return(dots[[1]])
x <- dots[[1]]
dots <- dots[-1]
while( length(dots) > 0 ) {
y <- dots[[1]]
if( length(dots) > 0)
dots <- dots[-1]
if(!is.null(colnames(y)) && colnames(x) != colnames(y))
warning('column names differ')
x <- .Call(C_do_rbind_xts,x,y,FALSE)
}
return(x)
}
xts/R/lag.xts.R 0000644 0001762 0000144 00000011412 14702273514 013000 0 ustar ligges users #
# 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 2 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 .
#' @rdname diff.xts
lag.xts <- function(x, k=1, na.pad=TRUE, ...) {
zooCompat <- getOption('xts.compat.zoo.lag')
if(is.logical(zooCompat) && zooCompat) {
k <- -k
if(missing(na.pad)) na.pad <- FALSE
}
if(length(k) > 1) {
if(is.null(names(k)))
names(k) <- paste("lag",k,sep="")
return(do.call("merge.xts", lapply(k, lag.xts, x=x, na.pad=na.pad,...)))
}
.Call(C_lag_xts, x, k, na.pad)
}
lagts.xts <- function(x, k=1, na.pad=TRUE, ...) {
# NOTE: not exported
if(length(k) > 1) {
if(is.null(names(k)))
names(k) <- paste("lag",k,sep="")
return(do.call("merge.xts", lapply(k, lag.xts, x=x, na.pad=na.pad,...)))
}
.Call(C_lag_xts, x, k, na.pad)
}
#' Lags and Differences of xts Objects
#'
#' Methods for computing lags and differences on xts objects. This provides
#' similar functionality as the \pkg{zoo} counterparts, but with some different
#' defaults.
#'
#' The primary motivation for these methods was to take advantage of a faster
#' C-level implementation. Another motivation was to make `lag()` behave using
#' standard sign for `k`. Both [zoo's lag() method][zoo::lag.zoo] and [`lag.default()`] require a
#' *negative* value for `k` in order to shift a series backward. So `k = 1`,
#' shifts the series *forward* one observation. This is especially confusing
#' because `k = 1` is the default for those functions. When `x` is an xts
#' object, `lag(x, 1)` returns an object where the value at time 't' is the
#' value at time 't-1' in the original object.
#'
#' Another difference is that `na.pad = TRUE` by default, to better reflect the
#' transformation visually and for functions the require positional alignment
#' of data.
#'
#' Set `options(xts.compat.zoo.lag = TRUE)` to use make `lag.xts()` consistent
#' with `lag.zoo()` by reversing the sign of `k` and setting `na.pad = FALSE`.
#'
#' @param x An xts object.
#' @param k Number of periods to shift.
#' @param lag Period to difference over.
#' @param differences Order of differencing.
#' @param arithmetic Should arithmetic or geometric differencing be used?
#' @param log Should (geometric) log differences be returned?
#' @param na.pad Should `NA` be added so the result has the same number of
#' observations as `x`?
#' @param \dots Additional arguments.
#'
#' @return An xts object with the desired lag and/or differencing.
#'
#' @author Jeffrey A. Ryan
#'
#' @references
#'
#' @keywords manip chron
#' @examples
#'
#' x <- xts(1:10, Sys.Date()+1:10)
#' lag(x) # currently using xts-style positive k
#'
#' lag(x, k=2)
#'
#' lag(x, k=-1, na.pad=FALSE) # matches lag.zoo(x, k=1)
#'
#' diff(x)
#' diff(x, lag=1)
#' diff(x, diff=2)
#' diff(diff(x))
#'
diff.xts <- function(x, lag=1, differences=1, arithmetic=TRUE, log=FALSE, na.pad=TRUE, ...)
{
if(!is.integer(lag) && any(is.na(as.integer(lag))))
stop("'lag' must be integer")
differences <- as.integer(differences[1L])
if(is.na(differences))
stop("'differences' must be integer")
if(is.logical(x)) {
x <- .xts(matrix(as.integer(x), ncol=NCOL(x)), .index(x),
tclass(x), dimnames=dimnames(x))
}
if(lag < 1 || differences < 1)
stop("'diff.xts' defined only for positive lag and differences arguments")
zooCompat <- getOption('xts.compat.zoo.lag')
if(is.logical(zooCompat) && zooCompat) {
# this has to negated to satisfy the test in lag.xts... oh my
lag <- -lag
if(missing(na.pad)) na.pad <- FALSE
}
if(differences > 1) {
if(arithmetic && !log) { #log is FALSE or missing
x <- x - lag.xts(x, k=lag, na.pad=na.pad)
} else {
if(log) {
x <- log(x/lag.xts(x, k=lag, na.pad=na.pad))
} else x <- x/lag.xts(x, k=lag, na.pad=na.pad)
}
diff(x, lag, differences=differences-1, arithmetic=arithmetic, log=log, na.pad=na.pad, ...)
} else {
if(arithmetic && !log) {
x - lag.xts(x, k=lag, na.pad=na.pad)
} else {
if(log) {
log(x/lag.xts(x, k=lag, na.pad=na.pad))
} else x/lag.xts(x, k=lag, na.pad=na.pad)
}
}
}
xts/R/as.numeric.R 0000644 0001762 0000144 00000011062 14654242576 013477 0 ustar ligges users #
# 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 2 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 .
as.numeric.xts <- function(x, drop=TRUE, ...)
{
if(drop)
return(as.numeric(coredata(x)))
.xts(matrix(as.numeric(coredata(x)),ncol=NCOL(x)), .index(x))
}
as.xts.numeric <-
function(x,order.by,dateFormat="POSIXct",frequency=NULL,...) {
# jmu
if(missing(order.by)) {
if(is.null(names(x)))
stop("order.by must be either 'names()' or otherwise specified")
else
# added '...' args to allow for tz specification
order.by <- do.call(paste('as',dateFormat,sep='.'),list(names(x)))
}
xx <- xts(x, order.by=order.by, frequency=frequency,
.CLASS='numeric', ...)
return(xx)
}
re.numeric <-
function(x,...) {
if( !is.null(dim(x)))
return(as.matrix(x))
# jmu
y <- as.numeric(x,...)
names(y) <- index(x)
return(y)
}
as.integer.xts <- function(x, drop=TRUE, ...)
{
if(drop)
return(as.integer(coredata(x)))
.xts(matrix(as.integer(coredata(x)),ncol=NCOL(x)), .index(x))
}
as.xts.integer <-
function(x,order.by,dateFormat="POSIXct",frequency=NULL,...) {
# jmu
if(missing(order.by)) {
if(is.null(names(x)))
stop("order.by must be either 'names()' or otherwise specified")
else
# added '...' args to allow for tz specification
order.by <- do.call(paste('as',dateFormat,sep='.'),list(names(x)))
}
xx <- xts(x, order.by=order.by, frequency=frequency,
.CLASS='integer', ...)
return(xx)
}
re.integer <-
function(x,...) {
if( !is.null(dim(x)))
return(as.matrix(x))
# jmu
y <- as.integer(x,...)
names(y) <- index(x)
return(y)
}
as.double.xts <- function(x, drop=TRUE, ...)
{
if(drop)
return(as.double(coredata(x)))
.xts(matrix(as.double(coredata(x)),ncol=NCOL(x)), .index(x))
}
as.xts.double <-
function(x,order.by,dateFormat="POSIXct",frequency=NULL,...) {
# jmu
if(missing(order.by)) {
if(is.null(names(x)))
stop("order.by must be either 'names()' or otherwise specified")
else
# added '...' args to allow for tz specification
order.by <- do.call(paste('as',dateFormat,sep='.'),list(names(x)))
}
xx <- xts(x, order.by=order.by, frequency=frequency,
.CLASS='double', ...)
return(xx)
}
re.double <-
function(x,...) {
if( !is.null(dim(x)))
return(as.matrix(x))
# jmu
y <- as.double(x,...)
names(y) <- index(x)
return(y)
}
as.complex.xts <- function(x, drop=TRUE, ...)
{
if(drop)
return(as.complex(coredata(x)))
.xts(matrix(as.complex(coredata(x)),ncol=NCOL(x)), .index(x))
}
as.xts.complex <-
function(x,order.by,dateFormat="POSIXct",frequency=NULL,...) {
# jmu
if(missing(order.by)) {
if(is.null(names(x)))
stop("order.by must be either 'names()' or otherwise specified")
else
# added '...' args to allow for tz specification
order.by <- do.call(paste('as',dateFormat,sep='.'),list(names(x)))
}
xx <- xts(x, order.by=order.by, frequency=frequency,
.CLASS='complex', ...)
return(xx)
}
re.complex <-
function(x,...) {
if( !is.null(dim(x)))
return(as.matrix(x))
# jmu
y <- as.complex(x,...)
names(y) <- index(x)
return(y)
}
as.logical.xts <- function(x, drop=TRUE, ...)
{
if(drop)
return(as.logical(coredata(x)))
.xts(matrix(as.logical(coredata(x)),ncol=NCOL(x)), .index(x))
}
as.xts.logical <-
function(x,order.by,dateFormat="POSIXct",frequency=NULL,...) {
# jmu
if(missing(order.by)) {
if(is.null(names(x)))
stop("order.by must be either 'names()' or otherwise specified")
else
# added '...' args to allow for tz specification
order.by <- do.call(paste('as',dateFormat,sep='.'),list(names(x)))
}
xx <- xts(x, order.by=order.by, frequency=frequency,
.CLASS='logical', ...)
return(xx)
}
re.logical <-
function(x,...) {
if( !is.null(dim(x)))
return(as.matrix(x))
# jmu
y <- as.logical(x,...)
names(y) <- index(x)
return(y)
}
xts/R/align.time.R 0000644 0001762 0000144 00000011632 14654242576 013465 0 ustar ligges users #
# 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 2 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 .
#' Align seconds, minutes, and hours to beginning of next period.
#'
#' Change timestamps to the start of the next period, specified in multiples of
#' seconds.
#'
#' This function is an S3 generic. The result is to round up to the next period
#' determined by 'n modulo x'.
#'
#' @param x Object containing timestamps to align.
#' @param n Number of seconds to adjust by.
#' @param \dots Additional arguments. See details.
#'
#' @return A new object with the same class as `x`.
#'
#' @author Jeffrey A. Ryan with input from Brian Peterson
#'
#' @seealso [`to.period()`]
#'
#' @keywords chron manip ts misc
#' @examples
#'
#' x <- Sys.time() + 1:1000
#'
#' # every 10 seconds
#' align.time(x, 10)
#'
#' # align to next whole minute
#' align.time(x, 60)
#'
#' # align to next whole 10 min interval
#' align.time(x, 10 * 60)
#'
align.time <- function(x, ...) {
UseMethod("align.time")
}
#' @rdname align.time
align.time.xts <- function(x, n=60, ...) {
if(n <= 0) stop("'n' must be positive")
.xts(x, .index(x) + (n-.index(x) %% n), tzone=tzone(x), tclass=tclass(x))
}
align.time.POSIXct <- function(x, n=60, ...) {
if(n <= 0) stop("'n' must be positive")
structure(unclass(x) + (n - unclass(x) %% n),class=c("POSIXct","POSIXt"))
}
align.time.POSIXlt <- function(x, n=60, ...) {
if(n <= 0) stop("'n' must be positive")
as.POSIXlt(align.time(as.POSIXct(x),n=n,...))
}
#' @rdname align.time
shift.time <- function(x, n=60, ...) {
UseMethod("shift.time")
}
shift.time.xts <- function(x, n=60, ...) {
.xts(x, .index(x) + n, tzone=tzone(x), tclass=tclass(x))
}
#' @rdname make.index.unique
is.index.unique <- function(x) {
UseMethod("is.time.unique")
}
#' @rdname make.index.unique
is.time.unique <- is.index.unique
is.time.unique.xts <- function(x) {
isOrdered(.index(x), strictly=TRUE)
}
is.time.unique.zoo <- function(x) {
isOrdered(index(x), strictly=TRUE)
}
#' Force Time Values To Be Unique
#'
#' A generic function to force sorted time vectors to be unique. Useful for
#' high-frequency time-series where original time-stamps may have identical
#' values. For the case of xts objects, the default `eps` is set to ten
#' microseconds. In practice this advances each subsequent identical time by
#' `eps` over the previous (possibly also advanced) value.
#'
#' The returned time-series object will have new time-stamps so that
#' `isOrdered(.index(x))` evaluates to `TRUE`.
#'
#' @param x An xts object, or POSIXct vector.
#' @param eps A value to add to force uniqueness.
#' @param drop Should duplicates be dropped instead of adjusted by `eps`?
#' @param fromLast When `drop = TRUE`, `fromLast` controls which duplicated
#' times are dropped. When `fromLast = FALSE`, the earliest observation with
#' an identical timestamp is kept and subsequent observations are dropped.
#' @param \dots Unused.
#'
#' @return A modified version of `x` with unique timestamps.
#'
#' @note Incoming values must be pre-sorted, and no check is done to make sure
#' that this is the case. \sQuote{integer} index value will be coerced to
#' \sQuote{double} when `drop = FALSE`.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`align.time()`]
#'
#' @rdname make.index.unique
#' @keywords ts
#' @examples
#'
#' ds <- options(digits.secs=6) # so we can see the change
#'
#' x <- xts(1:10, as.POSIXct("2011-01-21") + c(1,1,1,2:8)/1e3)
#' x
#' make.index.unique(x)
#'
#' options(ds)
#'
make.index.unique <- function(x, eps=0.000001, drop=FALSE, fromLast=FALSE, ...) {
UseMethod("make.index.unique")
}
#' @rdname make.index.unique
make.time.unique <- make.index.unique
make.index.unique.xts <- function(x, eps=0.000001, drop=FALSE, fromLast=FALSE, ...) {
if( !drop) {
.Call(C_make_index_unique, x, eps)
} else {
x[.Call(C_non_duplicates, .index(x), fromLast)]
}
}
make.index.unique.numeric <- function(x, eps=0.000001, drop=FALSE, fromLast=FALSE, ...) {
if( !drop) {
.Call(C_make_unique, x, eps)
} else {
x[.Call(C_non_duplicates, x, fromLast)]
}
}
make.index.unique.POSIXct <- function(x, eps=0.000001, drop=FALSE, fromLast=FALSE, ...) {
if( !drop) {
.Call(C_make_unique, x, eps)
} else {
x[.Call(C_non_duplicates, x, fromLast)]
}
}
xts/R/Date.R 0000644 0001762 0000144 00000001564 14654242576 012316 0 ustar ligges users #
# 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 2 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 .
#' @rdname as.xts
`as.xts.Date` <- function(x,...) {
xts(x=NULL,order.by=x,...)
}
xts/R/modify.args.R 0000644 0001762 0000144 00000003772 14654242576 013666 0 ustar ligges users #
# xts: eXtensible time-series
#
# Copyright (C) 2009-2015 Jeffrey A. Ryan jeff.a.ryan @ gmail.com
#
# Contributions from Ross Bennett and 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 2 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 .
modify.args <- function(formals, arglist, ..., dots=FALSE)
{
# modify.args function from quantstrat
# avoid evaluating '...' to make things faster
dots.names <- eval(substitute(alist(...)))
if(missing(arglist))
arglist <- NULL
arglist <- c(arglist, dots.names)
# see 'S Programming' p. 67 for this matching
# nothing to do if arglist is empty; return formals as a list
if(!length(arglist))
return(as.list(formals))
argnames <- names(arglist)
if(!is.list(arglist) && !is.null(argnames) && !any(argnames == ""))
stop("'arglist' must be a *named* list, with no names == \"\"")
.formals <- formals
onames <- names(.formals)
pm <- pmatch(argnames, onames, nomatch = 0L)
#if(any(pm == 0L))
# message(paste("some arguments stored for", fun, "do not match"))
names(arglist[pm > 0L]) <- onames[pm]
.formals[pm] <- arglist[pm > 0L]
# include all elements from arglist if function formals contain '...'
if(dots && !is.null(.formals$...)) {
dotnames <- names(arglist[pm == 0L])
.formals[dotnames] <- arglist[dotnames]
#.formals$... <- NULL # should we assume we matched them all?
}
# return a list (not a pairlist)
as.list(.formals)
}
xts/R/tclass.R 0000644 0001762 0000144 00000013422 14702273705 012716 0 ustar ligges users #
# 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 2 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 .
#' Get or Replace the Class of an xts Object's Index
#'
#' Generic functions to get or replace the class of an xts object's index.
#'
#' Internally, an xts object's index is a *numeric* value corresponding to
#' seconds since the epoch in the UTC timezone. The index class is stored as
#' the `tclass` attribute on the internal index. This is used to convert
#' the internal index values to the desired class when the `index`
#' function is called.
#'
#' The `tclass` function retrieves the class of the internal index, and
#' the `tclass<-` function sets it. The specified value for
#' `tclass<-` must be one of the following character strings:
#' `"Date"`, `"POSIXct"`, `"chron"`, `"yearmon"`,
#' `"yearqtr"`, or `"timeDate"`.
#'
#' @param x An xts object.
#' @param value The new index class (see Details for valid values).
#' @param \dots Arguments passed to other methods.
#'
#' @return A vector containing the class of the object's index.
#'
#' @note Both `indexClass` and `indexClass<-` are deprecated in favor
#' of `tclass` and `tclass<-`, respectively.
#'
#' Replacing the `tclass` can *potentially change* the values of the internal
#' index. For example, changing the 'tclass' from POSIXct to Date will
#' truncate the POSIXct value and convert the timezone to UTC (since the Date
#' class doesn't have a timezone). See the examples.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`index()`][xts::index.xts] has more information on the xts index, [`tformat()`]
#' details how the index values are formatted when printed, and [`tzone()`]
#' has more information about the index timezone settings.
#'
#' The following help pages describe the characteristics of the valid index
#' classes: [`POSIXct()`], [`Date()`], [chron()][chron::chron],
#' [`yearmon()`][zoo::zoo], [`yearqtr()`][zoo::zoo],
#' [`timeDate()`][timeDate::timeDate]
#'
#' @keywords ts utilities
#' @examples
#'
#' x <- timeBasedSeq('2010-01-01/2010-01-02 12:00')
#' x <- xts(seq_along(x), x)
#'
#' y <- timeBasedSeq('2010-01-01/2010-01-03 12:00/H')
#' y <- xts(seq_along(y), y, tzone = "America/New_York")
#'
#' # Changing the tclass *changes* the internal index values
#' head(y) # the index has times
#' head(.index(y))
#' tclass(y) <- "Date"
#' head(y) # the index prints as a Date
#' head(.index(y)) # the internal index is truncated
#'
tclass <-
function(x, ...) {
UseMethod('tclass')
}
#' @rdname tclass
tclass.default <-
function(x, ...)
{
attr(x, "tclass")
}
#' @rdname tclass
tclass.xts <-
function(x, ...)
{
tclass <- attr(attr(x, "index"), "tclass")
# For xts objects created pre-0.10.3
if (is.null(tclass)) {
# no tclass on the index
sq_tclass <- sQuote("tclass")
sq_both <- paste(sq_tclass, "or", sQuote(".indexCLASS"))
warn_msg <-
paste0("index does not have a ", sq_tclass, " attribute")
tclass <- attr(x, "tclass")
if (is.null(tclass)) {
# no tclass on the xts object, look for .indexCLASS
tclass <- attr(x, ".indexCLASS")
}
if (is.null(tclass)) {
# no .indexCLASS on the xts object
tc <- c("POSIXct", "POSIXt")
warn_msg <- paste0(warn_msg, "\n and xts object does not have a ",
sq_both, " attribute\n", " returning ", dQuote(tc))
warning(warn_msg)
return(tc)
}
sym <- deparse(substitute(x))
warning(warn_msg, "\n use ", sym,
" <- xts:::.update_index_attributes(", sym, ") to update the object")
}
return(tclass)
}
#' @rdname tclass
`tclass<-` <-
function(x,value) {
UseMethod('tclass<-')
}
#' @rdname tclass
`tclass<-.default` <-
function(x, value)
{
if (!is.null(value)) {
value <- as.character(value)
}
attr(x, "tclass") <- value
x
}
#' @rdname tclass
indexClass <-
function(x) {
.Deprecated("tclass", "xts")
tclass(x)
}
#' @rdname tclass
`indexClass<-` <-
function(x, value) {
.Deprecated("tclass<-", "xts")
`tclass<-`(x, value)
}
#' @rdname tclass
`tclass<-.xts` <-
function(x, value) {
if(!is.character(value) && length(value) != 1)
stop('improperly specified value for tclass')
# remove 'POSIXt' from value, to prevent tclass(x) <- 'POSIXt'
value <- value[!value %in% "POSIXt"]
if(length(value)==0L)
stop(paste('unsupported',sQuote('tclass'),'indexing type: POSIXt'))
if(!value[1] %in% c('dates','chron','POSIXlt','POSIXct','Date','timeDate','yearmon','yearqtr','xtime') )
stop(paste('unsupported',sQuote('tclass'),'indexing type:',as.character(value[[1]])))
# Add 'POSIXt' virtual class
if(value %in% c('POSIXlt','POSIXct'))
value <- c(value,'POSIXt')
# all index related meta-data will be stored in the index
# as attributes
if(isClassWithoutTZ(value)) {
attr(attr(x,'index'), 'tzone') <- 'UTC'
}
attr(attr(x,'index'), 'tclass') <- value
x_has_tz <- !isClassWithoutTZ(x)
if(x_has_tz && isClassWithoutTZ(value)) {
# update index values to midnight UTC (this also changes the tzone)
index(x) <- index(x)
}
# Remove class attrs (object created before 0.10-3)
attr(x, ".indexCLASS") <- NULL
attr(x, "tclass") <- NULL
x
}
xts/R/split.R 0000644 0001762 0000144 00000006326 14702273624 012565 0 ustar ligges users #
# 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 2 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 .
#' Divide into Groups by Time
#'
#' Creates a list of xts objects split along time periods.
#'
#' A quick way to break up a large xts object by standard time periods; e.g.
#' 'months', 'quarters', etc.
#'
#' [`endpoints()`] is used to find the start and end of each period (or
#' k-periods). See that function for valid arguments.
#'
#' The inputs are passed to [`split.zoo()`][zoo::split.zoo] when `f` is not a character vector.
#'
#' @param x An xts object.
#' @param f A character vector describing the period to split by.
#' @param drop Ignored by `split.xts()`.
#' @param k Number of periods to aggregate into each split. See details.
#' @param \dots Further arguments passed to other methods.
#'
#' @return A list of xts objects.
#'
#' @note [`aggregate.zoo()`][zoo::aggregate.zoo] is more flexible, though not
#' as fast for xts objects.
#'
#' @author Jeffrey A. Ryan
#'
#' @seealso [`endpoints()`], [`split.zoo()`][zoo::split.zoo],
#' [`aggregate.zoo()`][zoo::aggregate.zoo]
#'
#' @keywords utilities
#' @examples
#'
#' data(sample_matrix)
#' x <- as.xts(sample_matrix)
#'
#'
#' split(x)
#' split(x, f="weeks")
#' split(x, f="weeks", k=4)
#'
split.xts <-
function(x, f="months", drop=FALSE, k=1, ...) {
if(is.character(f) && length(f) == 1L) {
ep <- endpoints(x, on=f, k=k)
sp <- (ep + 1)[-length(ep)]
ep <- ep[-1]
out <- lapply(seq_along(ep), function(X) x[sp[X]:ep[X]])
if(f == "secs" || f == "mins") {
f <- substr(f, 1L, 3L)
}
f <- match.arg(f, c("years", "quarters", "months", "weeks", "days", "hours",
"minutes", "seconds", "milliseconds", "microseconds", "ms", "us"))
obs.for.names <- index(x)[sp]
outnames <-
switch(f,
"years" = format(obs.for.names, "%Y"),
"quarters" = as.character(as.yearqtr(as.POSIXlt(obs.for.names))),
"months" = format(obs.for.names, "%b %Y"),
"weeks" = format(obs.for.names, "%Y-%m-%d"),
"days" = format(obs.for.names, "%Y-%m-%d"),
"hours" = format(obs.for.names, "%Y-%m-%d %H:00:00"),
"minutes" = format(obs.for.names, "%Y-%m-%d %H:%M:00"),
"seconds" = format(obs.for.names, "%Y-%m-%d %H:%M:%S"),
"milliseconds" = ,
"ms" = format(obs.for.names, "%Y-%m-%d %H:%M:%OS3"),
"microseconds" = ,
"us" = format(obs.for.names, "%Y-%m-%d %H:%M:%OS6"))
setNames(out, outnames)
} else
NextMethod("split")
}
xts/R/merge.R 0000644 0001762 0000144 00000020035 14702273432 012517 0 ustar ligges users #
# 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 2 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 .
#' Merge xts Objects
#'
#' Perform merge operations on xts objects by time index.
#'
#' This xts method is compatible with [zoo's merge() method][zoo::merge.zoo] but implemented almost
#' entirely in C-level code for efficiency.
#'
#' The function can perform all common database join operations along the time
#' index by setting 'join' to one of the values below. Note that 'left' and
#' 'right' are only implemented for two objects.
#'
#' * outer: full outer (all rows in all objects)
#' * inner: only rows with common indexes in all objects
#' * left: all rows in the first object, and rows from the second object that
#' have the same index as the first object
#' * right: all rows in the second object, and rows from the first object that
#' have the same index as the second object
#'
#' The above join types can also be accomplished by setting 'all' to one of the
#' values below.
#'
#' * outer: `all = TRUE` or `all = c(TRUE, TRUE)`
#' * inner: `all = FALSE` or `all = c(FALSE, FALSE)`
#' * left: `all = c(TRUE, FALSE)`
#' * right: `all = c(FALSE, TRUE)`
#'
#' The result will have the timezone of the leftmost argument if available. Use
#' the 'tzone' argument to override the default behavior.
#'
#' When `retclass = NULL` the joined objects will be split and reassigned
#' silently back to the original environment they are called from. This is for
#' backward compatibility with zoo, but unused by xts. When `retclass = FALSE`
#' the object will be stripped of its class attribute. This is for internal use.
#'
#' See the examples in order to join using an 'all' argument that is the same
#' arguments to join, like you can do with `merge.zoo()`.
#'
#' @param \dots One or more xts objects, or objects coercible to class xts.
#' @param all A logical vector indicating merge type.
#' @param fill Values to be used for missing elements.
#' @param suffixes Suffix to be added to merged column names.
#' @param join Type of database join. One of 'outer', 'inner', 'left', or 'right'.
#' @param retside Which side of the merged object should be returned (2-case only)?
#' @param retclass Either a logical value indicating whether the result should
#' have a 'class' attribute, or the name of the desired class for the result.
#' @param tzone Time zone to use for the merged result.
#' @param drop Not currently used.
#' @param check.names Use [`make.names()`] to ensure column names are vaild \R
#' object names?
#'
#' @return A new xts object containing the appropriate elements of the
#' objects passed in to be merged.
#'
#' @note This is a highly optimized merge, specifically designed for ordered
#' data. The only supported merging is based on the underlying time index.
#'
#' @author Jeffrey A. Ryan
#'
#' @references Merge Join Discussion:
#'
#'
#' @keywords manip utilities
#' @examples
#'
#' (x <- xts(4:10, Sys.Date()+4:10))
#' (y <- xts(1:6, Sys.Date()+1:6))
#'
#' merge(x,y)
#' merge(x,y, join='inner')
#' merge(x,y, join='left')
#' merge(x,y, join='right')
#'
#' merge.zoo(zoo(x),zoo(y),zoo(x), all=c(TRUE, FALSE, TRUE))
#' merge(merge(x,x),y,join='left')[,c(1,3,2)]
#'
#' # zero-width objects (only index values) can be used
#' xi <- xts( , index(x))
#' merge(y, xi)
#'
merge.xts <- function(...,
all=TRUE,
fill=NA,
suffixes=NULL,
join="outer",
retside=TRUE,
retclass="xts",
tzone=NULL,
drop=NULL,
check.names=NULL) {
if(is.null(check.names)) {
check.names <- TRUE
}
if(is.logical(retclass) && !retclass) {
setclass=FALSE
} else setclass <- TRUE
fill.fun <- NULL
if(is.function(fill)) {
fill.fun <- fill
fill <- NA
}
# as.list(substitute(list(...))) # this is how zoo handles colnames - jar
mc <- match.call(expand.dots=FALSE)
dots <- mc$...
if(is.null(suffixes)) {
syms <- names(dots)
if(is.null(syms)) {
# Based on makeNames() in merge.zoo()
syms <- substitute(alist(...))[-1L]
nm <- names(syms)
fixup <- if (is.null(nm)) seq_along(syms) else !nzchar(nm)
dep <- sapply(syms[fixup], function(x) deparse(x, nlines = 1L))
if(is.null(nm)) {
nm <- dep
} else if(any(fixup)) {
nm[fixup] <- dep
}
syms <- nm
} else {
have.symnames <- nzchar(syms)
if(any(!have.symnames)) {
syms[!have.symnames] <- as.character(dots[!have.symnames])
}
}
} else
if(length(suffixes) != length(dots)) {
warning("length of suffixes and does not match number of merged objects")
syms <- as.character(dots)
# should we ignore suffixes here?
#suffixes <- NULL
} else {
syms <- as.character(suffixes)
}
.times <- .External(C_number_of_cols, ...)
# moved call to make.names inside of mergeXts/do_merge_xts
symnames <- rep(syms, .times)
suffixes <- rep(suffixes, .times)
if(length(dots) == 1) {
# this is for compat with zoo; one object AND a name
if(!is.null(names(dots))) {
x <- list(...)[[1]]
if(is.null(colnames(x)))
colnames(x) <- symnames
return(x)
}
}
if( !missing(join) ) {
# join logic applied to index:
# inspired by: http://blogs.msdn.com/craigfr/archive/2006/08/03/687584.aspx
#
# (full) outer - all cases, equivelant to all=c(TRUE,TRUE)
# left - all x, && y's that match x
# right - all ,y && x's that match y
# inner - only x and y where index(x)==index(y)
all <- switch(pmatch(join,c("outer","left","right","inner")),
c(TRUE, TRUE ), # outer
c(TRUE, FALSE), # left
c(FALSE, TRUE ), # right
c(FALSE, FALSE) # inner
)
if( length(dots) > 2 ) {
all <- all[1]
warning("'join' only applicable to two object merges")
}
}
if( length(all) != 2 ) {
if( length(all) > 2 )
warning("'all' must be of length two")
all <- rep(all[1], 2)
}
if( length(dots) > 2 )
retside <- TRUE
if( length(retside) != 2 )
retside <- rep(retside[1], 2)
x <- .External(C_mergeXts,
all=all[1:2],
fill=fill,
setclass=setclass,
symnames=symnames,
suffixes=suffixes,
retside=retside,
env=new.env(),
tzone=tzone,
check.names=check.names,
...)
if(!is.logical(retclass) && retclass != 'xts') {
asFun <- paste("as", retclass, sep=".")
if(!exists(asFun)) {
warning(paste("could not locate",asFun,"returning 'xts' object instead"))
return(x)
}
xx <- try(do.call(asFun, list(x)))
if(!inherits(xx,'try-error')) {
return(xx)
}
}
if(!is.null(fill.fun)) {
fill.fun(x)
} else
return(x)
}
#' @rdname merge.xts
cbind.xts <- function(..., all=TRUE, fill=NA, suffixes=NULL) {
merge.xts(..., all=all, fill=fill, suffixes=suffixes)
}
.merge.xts.scalar <- function(x, length.out, ...) {
if( length.out == 0)
return(vector(storage.mode(x), 0))
if( length(x) == 1 )
return(matrix(rep(x, length.out=length.out)))
if( NROW(x) == length.out )
return(x)
stop("improper length of one or more arguments to merge.xts")
}
xts/R/Math.xts.R 0000644 0001762 0000144 00000003400 14654242576 013136 0 ustar ligges users #
# 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 2 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 .
# This code adapted from Ops.zoo.R
cumsum.xts <- function(x)
{
if( NCOL(x) == 1 ) {
x[] <- cumsum(coredata(x))
} else x[] <- apply(coredata(x), 2, function(y) cumsum(y))
x
}
cumprod.xts <- function(x)
{
if( NCOL(x) == 1 ) {
x[] <- cumprod(coredata(x))
} else x[] <- apply(coredata(x), 2, function(y) cumprod(y))
x
}
cummin.xts <- function(x)
{
if( NCOL(x) == 1 ) {
x[] <- cummin(coredata(x))
} else x[] <- apply(coredata(x), 2, function(y) cummin(y))
x
}
cummax.xts <- function(x)
{
if( NCOL(x) == 1 ) {
x[] <- cummax(coredata(x))
} else x[] <- apply(coredata(x), 2, function(y) cummax(y))
x
}
mean.xts <- function(x,...) {
if(is.vector(x) ||is.null(ncol(x)) || ncol(x)==1){
x<-as.numeric(x)
mean(x,...)
} else apply(x,2,mean.xts,...)
}
sd.xts <- function(x,na.rm=FALSE) {
if(is.vector(x) || is.null(ncol(x)) || ncol(x)==1){
x<-as.numeric(x)
sd(x,na.rm=na.rm)
} else apply(x,2,sd,na.rm=na.rm)
}
xts/vignettes/ 0000755 0001762 0000144 00000000000 14703504525 013105 5 ustar ligges users xts/vignettes/xts.Rnw 0000644 0001762 0000144 00000100654 14634167654 014434 0 ustar ligges users %\VignetteIndexEntry{xts: Extensible Time Series}
\documentclass{article}
\usepackage{hyperref}
\hypersetup{colorlinks,%
citecolor=black,%
linkcolor=blue,%
urlcolor=blue,%
}
\title{\bf xts: Extensible Time Series }
\author{Jeffrey A. Ryan \and Joshua M. Ulrich}
\date{May 18, 2008}
\begin{document}
\maketitle
\tableofcontents
\section{Introduction}
The statistical language {\tt R}~\cite{R}
offers the time-series analyst a variety of mechanisms
to both store and manage time-indexed data.
Native {\tt R} classes potentially suitable
for time-series data include {\tt data.frame}, {\tt matrix}, {\tt vector}, and
{\tt ts} objects. Additional time-series tools have been subsequently introduced
in contributed packages to
handle some of the domain-specific shortcomings of the native {\tt R} classes.
These include {\tt irts} from the {\tt tseries} package\cite{tseries},
{\tt timeSeries} from the {\tt Rmetrics} bundle\cite{rmetrics}, and
{\tt zoo}~\cite{zoo} from their
respective packages. Each of these contributed classes provides unique solution
to many of the issues
related to working with time-series in R.
While it seems a bit paradoxical with all the current options
available, what {\tt R} really needed was one more
time-series class. Why? Users of R have had many choices over the
years for managing time-series data. This variety has meant that
developers have had to pick and choose the classes they would support,
or impose the necessary conversions upon the end-user. With the sheer
magnitude of software packages available from CRAN, it has become a challenge
for users and developers
to select a time-series class that will manage the needs of the
individual user, as well as remain compatible with the broadest audience.
What may be sufficient for one use --- say a quick correlation matrix may be
too limiting when more information needs to be incorporated
in a complex calculation.
This is especially true for functions that rely on time-based indexes to
be manipulated or checked.
The previous solution to managing different data needs often
involved a series of {\tt as} calls,
to coerce objects from one type to another. While this may
be sufficient for many cases, it is less flexible than allowing the users
to simply use the object they are accustomed to, or quite possibly require.
Additionally, all current coercion methods fail to maintain the original
object's data in its entirety. Converting from a {\tt timeSeries} class to
{\tt zoo} would cause attributes such as
{\em FinCenter}, {\em format}, and {\em recordIDs} to be lost.
Converting back to a {\tt timeSeries} would then add new
values different than the original.
For many calculations that do not modify the data, this is most likely
an acceptable side effect. For functions that convert data ---
such as {\tt xts}'s {\tt to.period} --- it limits the value of the function,
as the returned object is missing
much of what may have been a factor in the original class consideration.
One of the most important additions the new {\tt xts} class makes
to the R user's
workflow doesn't use {\tt xts} at all, at least not explicitly.
By converting data to {\tt xts} inside a function, the function developer
is guaranteed to have to only manage a single class of objects.
It becomes unecessary to write specific methods to handle different data.
While many functions do have
methods to accommodate different classes, most do not. Before {\tt xts}, the
{\tt chartSeries} function in the {\tt quantmod} package\cite{quantmod}
was only able to handle {\tt zoo} objects well.
Work had been done to allow for {\tt timeSeries} objects to be used as well, but
many issues were still being worked out.
With {\tt xts} now used internally, it is
possible to use \emph{any} of R's time-series classes.
Simultaneously saving development time and
reducing the learning/using curve for the end user. The function now
simply handles whatever time-series object it receives
exactly as the user expects --- without complaint.
More details, as well as examples of incorporating {\tt xts} into
functions will be covered later in this document.
While it may seem that {\tt xts} is primarily a tool
to help make existing R code
more user-friendly, the opportunity to add exciting
(to software people) new functionality
could not be passed up. To this end, {\tt xts}
offers the user the ability to add
custom attributes to any object --- during its construction
or at any time thereafter. Additionally,
by requiring that the index attribute be derived from one of
R's existing time-based classes, {\tt xts} methods can
make assumptions, while subsetting by time or date, that allow for
much cleaner and accurate data manipulation.
The remainder of this introduction will
examine what an {\tt xts} object consists of and
its basic usage, explain how developing with {\tt xts} can save
package development time, and finally will demonstrate
how to extend the class - informally
and formally.
\pagebreak
\section{The structure of {\tt xts}}
To understand a bit more of \emph{what an xts object can do}, it may
be beneficial to know \emph{what an xts object is}. This section
is intended to provide a quick overview of the basics of the
class, as well as what features make it unique.
\subsection{It's a {\tt zoo} in here}
At the core of an {\tt xts} object is a {\tt zoo} object from the package of
the same name. Simplified, this class contains an array of values
comprising your data (often in matrix form) and an index
attribute to provide information about
the data's ordering. Most of the details surrounding zoo
objects apply equally to xts. As it would be redundent to simply retell
the excellent introductory zoo vignette, the reader is advised to
read, absorb, and re-read that documentation to best
understand the power of this class. The authors of the {\tt xts}
package recognize that
{\tt zoo}'s strength comes from its
simplicity of use, as well as its overall flexibility. What motivated the
{\tt xts} extension was a desire to have even more flexibility, while
imposing reasonable constraints to make this class into a true time-based one.
\subsection{{\tt xts} modifications}
Objects of class {\tt xts} differ from objects of class
{\tt zoo} in three key ways: the use of formal time-based
classes for indexing,
internal xts properties, and perhaps most uniquely
--- user-added attributes.
\subsubsection*{True time-based indexes}
To allow for functions that make use of {\tt xts} objects
as a general time-series object - it was necessary to
impose a simple rule on the class. The index of each
{\tt xts} object \emph{must} be of a known and supported
time or date class. At present this includes any one of
the following - Date, POSIXct, chron, yearmon, yearqtr, or
timeDate. The relative merits of each are left to
the judgement of the user, though the first three are expected
to be sufficient for most applications.
\subsubsection*{Internal attributes: .CLASS, .ROWNAMES, etc.}
In order for one major feature of the {\tt xts} class
to be possible - the conversion and re-conversion of classes
to and from {\tt xts} - certain elements must be preserved within
the converted object. These are for internal use, and
as such require little further explanation in an introductory
document. Interested readers are invited to examine the source as
well as read the developer documentation.
\subsubsection*{xtsAttributes}
This is what makes the xts class an \emph{extensible}
time-series class. Arbitrary attributes may be assigned
and removed from the object without causing issues with the data's display or
otherwise. Additionally this is where \emph{other}
class specific attributes (e.g. \emph{FinCenter} from {\tt timeSeries})
are stored during conversion
to an xts object so they may be restored with {\tt reclass}.
\pagebreak
\section{Using the {\tt xts} package}
Just what is required to start using {\tt xts}? Nothing more
than a simple conversion of your current time-series data with
{\tt as.xts}, or the creation of a new object with the {\tt xts} constructor.
\subsection{Creating data objects: {\tt as.xts} and {\tt xts}}
There are two equally valid mechanisms to create an {\tt xts}
object - coerce a supported time-series class to {\tt xts} with
a call to {\tt as.xts} or create a new object from scratch
with {\tt xts}.
\subsubsection*{Converting your \emph{existing} time-series data: {\tt as.xts}}
If you are already comfortable using a particular
time-series class in {\tt R}, you can still access
the functionality of {\tt xts} by converting your
current objects.
Presently it is possible to convert all the major
time-series like classes in {\tt R} to {\tt xts}. This list
includes objects of class:
matrix, data.frame, ts, zoo, irts, and timeSeries.
The new object will maintain all the necessary information
needed to {\tt reclass} this object back to its
original class if that is desired. Most classes
after re-conversion will be identical to similar modifications
on the original object, even
after sub-setting or other changes while an {\tt xts} object.
<>=
require(xts)
data(sample_matrix)
class(sample_matrix)
str(sample_matrix)
matrix_xts <- as.xts(sample_matrix,dateFormat='Date')
str(matrix_xts)
df_xts <- as.xts(as.data.frame(sample_matrix),
important='very important info!')
str(df_xts)
@
A few comments about the above. {\tt as.xts} takes different arguments, depending
on the original object to be converted. Some classes do not contain enough
information to infer a time-date class. If that is the case, POSIXct is used by
default. This is the case with both matrix and data.frame objects. In the preceding
examples we first requested that the new date format be of type 'Date'. The
second example was left to the default {\tt xts} method
with a custom attribute added.
\subsubsection*{Creating new data: the {\tt xts} constructor}
Data objects can also be constructed directly from raw data with
the {\tt xts} constructor function, in essentially the same way
a {\tt zoo} object is created with the exception that at present
there is no equivelant {\tt zooreg} class.
<>=
xts(1:10, Sys.Date()+1:10)
@
\subsection{{\tt xts} methods}
There is a full complement of standard methods to make use of the features
present in {\tt xts} objects. The generic methods currently
extended to {\tt xts} include ``{\tt [}'',
{\tt cbind}, {\tt rbind}, {\tt c}, {\tt str}, {\tt Ops},
{\tt print}, {\tt na.omit}, {\tt time}, {\tt index},
{\tt plot} and {\tt coredata}. In addition, most methods that can accept
zoo or matrix objects will simply work as expected.
A quick tour of some of the methods leveraged by {\tt xts}
will be presented here, including subsetting via ``{\tt [}'',
indexing objects with {\tt tclass} and {\tt convertIndex},
and a quick look at plotting {\tt xts} objects with the {\tt plot}
function.
\subsubsection*{Subsetting}
The most noticable difference in the behavior of \texttt{xts} objects
will be apparent in the use of the ``{\tt [}'' operator. Using
special notation, one can use date-like strings to extract
data based on the time-index. Using increasing levels of time-detail,
it is possible to subset the object by year, week, days - or even seconds.
The {\em i} (row)
argument to the subset operator ``{\tt [}'', in addition to accepting numeric
values for indexing,
can also be a character string, a time-based object, or a vector of either.
The format must left-specified with respect to the standard ISO:8601
time format --- {\em ``CCYY-MM-DD HH:MM:SS''}~\cite{ISO}. This means that for one
to extract a particular month, it is necesssary to fully specify the
year as well. To identify a particular hour, say all observations
in the eighth hour on January 1, 2007, one would likewise need
to include the full year, month and day - e.g. ``2007-01-01 08''.
It is also possible to explicitly request a range of times via
this index-based subsetting, using
the ISO-recommended ``/'' as the range seperater.
The basic form is {\em ``from/to''},
where both {\em from} and {\em to}
are optional. If either side is missing, it is interpretted as
a request to retrieve data from the beginning, or through the end of the
data object.
Another benefit to this method is that exact starting and ending
times need not match the underlying data - the nearest available
observation will be returned that is within the requested time
period.
The following example shows how
to extract the entire month of March 2007 - without having to
manually identify the index positions or match the underlying
index type. The results have been abbreviated to save space.
<>=
matrix_xts['2007-03']
@
<>=
head(matrix_xts['2007-03'],5)
cat('...\n')
@
Now extract all the data from the beginning through
January 7, 2007.
<>=
matrix_xts['/2007-01-07']
@
<>=
matrix_xts['/2007-01-07']
@
Additional xts tools providing subsetting are the
{\tt first} and {\tt last} functions.
In the spirit of head and tail from
the {\em utils} recommended package, they allow
for string based subsetting, without forcing
the user to conform to the specifics of the
time index, similar in usage to the {\em by}
arguments of {\tt aggregate.zoo} and {\tt seq.POSIXt}.
Here is the first 1 week of the data
<>=
first(matrix_xts,'1 week')
@
<>=
head(first(matrix_xts,'1 week'))
@
...and here is the first 3 days of the
last week of the data.
<>=
first(last(matrix_xts,'1 week'),'3 days')
@
\subsubsection*{Indexing}
While the subsetting ability of the above makes
exactly {\em which} time-based class you choose
for your index a bit less relevant, it is none-the-less
a factor that is beneficial to have control over.
To that end, {\tt xts} provides facilities for indexing
based on any of the current time-based classes. These
include {\tt Date}, {\tt POSIXct}, {\tt chron}, {\tt yearmon},
{\tt yearqtr}, and {\tt timeDate}. The index itself may
be accessed via the zoo generics extended to xts --- {\tt index} and
the replacement function {\tt index<-}.
It is also possible to directly query and set the
index class of an {\tt xts} object by using the respective functions
{\tt tclass} and {\tt tclass<-}.
Temporary conversion, resulting in a new object with the requested
index class, can be accomplished via the {\tt convertIndex} function.
<>=
tclass(matrix_xts)
tclass(convertIndex(matrix_xts,'POSIXct'))
@
\pagebreak
\subsubsection*{Plotting}
\SweaveOpts{height=5,width=10}
%\setkeys{Gin}{width=0.8\textwidth}
The use of time-based indexes within {\tt xts} allows
for assumptions to be made regarding the x-axis
of plots. The {\tt plot} method
makes use of the {\tt xts} function {\tt axTicksByTime}, which
heuristically identifies suitable tickmark locations
for printing given a time-based object.
When {\tt axTickByTime} is called with its
{\tt ticks.on} argument set to ``auto'', the result
is a vector of suitably chosen tickmark locations.
One can also specify the specific points to use
by passing a character string to the argument
indicating which time period to create tickmarks on.
<>=
axTicksByTime(matrix_xts, ticks.on='months')
@
A simple example of the plotting functionality
offered by this labelling can be seen here:
\begin{center}
<>=
plot(matrix_xts[,1],major.ticks='months',minor.ticks=FALSE,main=NULL,col=3)
@
\end{center}
\subsection{Restoring the original class - {\tt reclass} \& {\tt Reclass}}
By now you may be interested in some of the xts functionality
presented, and wondering how to incorporate it into
a current workflow --- but not yet ready to commit
to using it exclusively.
If it is desirable to only use the subsetting tools
for instance, a quick conversion to xts via {\tt as.xts}
will allow full access to the above subsetting tools. When
it is then necessary to continue your analysis using
the original class, it is as simple as calling the
function {\tt reclass} to return the object to its
original class.
\subsubsection*{(Re)converting classes manually: {\tt reclass}}
<>=
# using xts-style subsetting doesn't work on non-xts objects
sample_matrix['2007-06']
# convert to xts to use time-based subsetting
str(as.xts(sample_matrix)['2007-06'])
# reclass to get to original class back
str(reclass(as.xts(sample_matrix)['2007-06']))
@
This differs dramatically from the standard {\tt as.*****}
conversion though. Internally, key attributes of your
original data object are preserved and adjusted to
assure that the process introduces no changes other
than those requested. Think of it as a smart {\tt as}.
Behind the scenes, {\tt reclass} has enormous value
in functions that convert all incoming data to {\tt xts}
for simplified processing. Often it is necessary to
return an object back to the user in the class he
is expecting --- following the principal of least surprise.
It is in these circumstances where {\tt reclass} can
turn hours of tedious development into mere minutes per function. More
details on the details of using this functionality
for developers will be covered in section \ref{developer},
\textbf{Developing with xts}.
A user friendly interface of this \emph{reclass} functionality, though
implicit, is available in the {\tt Reclass} function.
It's purpose is to make it easy to preserve an object's attributes after calling
a function that is not programmed to be aware of your particular class.
\pagebreak
\subsubsection*{Letting xts handle the details: {\tt Reclass}}
If the function you require does not make use of
{\tt reclass} internally, it may still be possible to let
xts convert and reconvert your time-based object for you.
The caveat here is that the object returned:
\begin{quote}
\begin{itemize}
\item must be of the same length as the first argument to
the function.
\item intended to be coerced back to the class of the first
argument
\end{itemize}
\end{quote}
Simply wrapping the function
that meets these criteria in {\tt Reclass} will
result in an
attempt to coerce the returned output of the function
<>=
z <- zoo(1:10,Sys.Date()+1:10)
# filter converts to a ts object - and loses the zoo class
(zf <- filter(z, 0.2))
class(zf)
# using Reclass, the zoo class is preserved
(zf <- Reclass(filter(z, 0.2)))
class(zf)
@
The {\tt Reclass} function is still a bit experimental, and will
certainly improve in time, but for now provides at least
an alternative option to maintain your object's class
and attributes when the function you require can't on its own.
\subsection{Additional time-based tools}
In addition to the core {\tt xts} tools covered
above, there are more functions that are included
in xts to make the process of dealing with
time-series data easier. Some of these have been
moved from the package {\tt quantmod} to {\tt xts}
to make it easier to use them within other applications.
\subsubsection*{Calculate periodicity}
The {\tt periodicity} function provides
a quick summary as to the underlying
periodicity of most time-series like
objects. Primarily a wrapper to {\tt difftime}
it provides a quick and concise summary
of your data.
<>=
periodicity(matrix_xts)
@
\subsubsection*{Find endpoints by time}
Another common issue with time-series data
is identifying the endpoints with respect to
time. Often it is necessary to break data
into hourly or monthly intervals to calculate
some statistic. A simple call to {\tt endpoints}
offers a quick vector of values suitable
for subsetting a dataset by. Note that the first
element it zero, which is used to delineate the \emph{end}.
<>=
endpoints(matrix_xts,on='months')
endpoints(matrix_xts,on='weeks')
@
\subsubsection*{Change periodicity}
One of the most ubiquitous type of data
in finance is OHLC data (Open-High-Low-Close). Often is is necessary
to change the periodicity of this data to something
coarser - e.g. take daily data and aggregate to weekly
or monthly. With {\tt to.period} and related wrapper
functions it is a simple proposition.
<>=
to.period(matrix_xts,'months')
periodicity(to.period(matrix_xts,'months'))
# changing the index to something more appropriate
to.monthly(matrix_xts)
@
The {\tt to.monthly} wrapper automatically requests that the
returned object have an index/rownames using
the {\tt yearmon} class. With the {\tt indexAt}
argument it is possible to align most series
returned to the end of the period, the beginning of the period,
or the first or last observation of the period ---
even converting to something like {\tt yearmon} is supported. The online
documentation provides more details as to additional
arguments.
\subsubsection*{Periodically apply a function}
Often it is desirable to be able to calculate a
particular statistic, or evaluate a function, over
a set of non-overlapping time periods. With the
{\tt period.apply} family of functions
it is quite simple.
The following examples illustrate a
simple application of the {\tt max} function
to our example data.
<>=
# the general function, internally calls sapply
period.apply(matrix_xts[,4],INDEX=endpoints(matrix_xts),FUN=max)
@
<>=
# same result as above, just a monthly interface
apply.monthly(matrix_xts[,4],FUN=max)
@
<>=
# using one of the optimized functions - about 4x faster
period.max(matrix_xts[,4], endpoints(matrix_xts))
@
In addition to {\tt apply.monthly}, there are
wrappers to other common time frames including:
{\tt apply.daily}, {\tt apply.weekly}, {\tt apply.quarterly},
and {\tt apply.yearly}. Current optimized functions
include {\tt period.max}, {\tt period.min}, {\tt period.sum},
and {\tt period.prod}.
\pagebreak
\section{Developing with {\tt xts}}
\label{developer}
While the tools available to the xts \emph{user} are quite
useful, possibly greater utility comes from using xts
internally as a \emph{developer}. Bypassing
traditional S3/S4 method dispatch and
custom if-else constructs to handle different time-based
classes, {\tt xts} not only makes it easy to
handle all supported classes in one consistent manner,
it also allows the whole process to be invisible
to the function user.
\subsection{One function for all classes: {\tt try.xts}}
With the proliferation of data classes in R, it can be
tedious, if not entirely impractical, to manage interfaces to all
classes.
Not only does trying to handle every possible class present
non-trivial design issues, the developer is also forced
to learn and understand the nuances of up to eight or
more classes. For each of these classes it is then
ncessary to write and manage
corresponding methods for each case.
At best, this reduces the time available
to devote to core function functionality --- at worst
is a prime opportunity to introduce errors that
inevitibly come from this massive increase in code.
The solution to this issue is to use one class
internally within your package, or more generally your
entire workflow. This can
be accomplished in one of two ways: force your users
to adopt the convention you do, or allow for
multiple object classes by relying on internal
code to convert to one consistent type.
Using the second approach offers the most end-user
flexibility, as class conversions are no longer
required simply to make use of package functionality. The
user's own workflow need not be interrupted with unproductive and
potentially error-prone conversions and reconversions.
Using the functionality of {\tt try.xts} and {\tt reclass} offered
by the xts package allows the developer an opportunity
to cleanly, and reliably, manage data with the least amount
of code, and the least number of artificial end-user restrictions.
An example from the xts package illustrates just how simple
this can be.
<>=
period.apply
@
Some explanation of the above code is needed. The
{\tt try.xts} function takes three arguments, the first
is the object that the developer is trying to
convert, the second \ldots is any additional arguments to
the {\tt as.xts} constructor that is called internally
(ignore this for the most part --- though it should
be noted that this is an R dots argument \ldots), and the third is
a what the result of an error should be.
Of the three, {\tt error} is probably the most useful
from a design standpoint. Some functions may not
be able to deal with data that isn't time-based. Simple
numerical vectors might not contain enough information
to be of any use. The \emph{error} argument
lets the developer decide if the function should be
halted at this point, or continue onward.
If a logical value, the result is
handled by R's standard error mechanism during the try-catch
block of code internal to {\tt try.xts}. If error is
a character string, it is returned to the standard output
as the message. This allows for diagnostic messages to
be fine tuned to your particular application.
The result of this call, if successful (or if {\tt error=FALSE})
is an object that may be of class {\tt xts}. If
your function can handle either numeric data or time-based
input, you can branch code here for cases you expect. If your
code has been written to be more general
at this point, you can simply continue with your calculations,
the originally converted object will contain
the information that will be required to reclass it at the end.
A note of importance here: if you are planning on
returning an object that is of the original class, it
is important to not modify the originally coverted object - in this
case that would be the {\tt x} result of the {\tt try.xts} call.
You will notice that the function's result is assigned to
{\tt xx} so as not to impact the original converted function. If
this is not possible, it is recommended to copy the object first
to preserve an untouched copy for use in the {\tt reclass} function.
Which leads to the second part of the process of developing with
xts.
\subsection{Returning the original class: {\tt reclass}}
The {\tt reclass} function takes the object you are
expecting to return to your user (the result of all your
calculations) and optionally an {\tt xts} object
that was the result of the original {\tt try.xts} call.
It is important to stress that the {\tt match.to} object
\emph{must be an untouched object} returned from the
{\tt try.xts} call. The only exception here is
when the resultant data has changed dimension --- as is
the case in the {\tt period.apply} example. As reclass
will try and convert the first argument to the orginal
class of the second (the original class passed to the function),
it must have the same general row dimension of the original.
A final note on using {\tt reclass}. If the {\tt match.to} argument
is left off, the conversion will only be attempted if the object
is of class {\tt xts} and has a {\tt CLASS} attribute that is
not {\tt NULL}, else the object is simply
returned. Essentially if the object meant to be
reconverted is already of in the form needed by
the individual reclass methods, generally nothing
more needs to be done by the developer.
In many cases your function does not need to return
an object that is expected to be used in the same context
as the original. This would be the case for functions
that summarize an object, or perform some statistical analysis.
For functions that do not need the {\tt reclass} functionality,
a simple use of {\tt try.xts} at the beginning of the function
is all that is needed to make use of this single-interface
tool within {\tt xts}.
Further examples can be found in the {\tt xts} functions
{\tt periodicity} and {\tt endpoints} (no use of reclass), and
{\tt to.period} (returns an object of the original's class).
The package {\tt quantmod} also utilizes the {\tt try.xts}
functionality in its {\tt chartSeries} function --- allowing
financial charts for all time-based classes.
Forthcoming developer documentation will examine the functions
highlighted above, as well go into more detail on exceptional
cases and requirements.
\pagebreak
\section{Customizing and Extending xts}
As \emph{extensible} is in the name of
the package, it is only logical that it can be extended.
The two obvious mechanisms to make {\tt xts}
match the individual needs of a diverse user
base is the introduction of custom
attributes, and the idea of subclassing the entire
{\tt xts} class.
\subsection{{\tt xtsAttributes}}
What makes an R attribute an {\tt xtsAttribute}?
Beyond the sematics, xtsAttributes are designed to
persist once attached to an object, as well as not get
in the way of other object functionality.
All xtsAttributes are indeed R attributes, though
the same can not be said of the reverse --- all
R attributes are \emph{not} xtsAttributes!
Attaching arbitrary attributes to most (all?) classes
other than {\tt xts} will cause the attribute to be displayed
during most calls that print the object. While this isn't
necessarily devestating, it is often time unsightly, and sometimes
even confusing to the end user (this may depend on the quality your users).
xts offers the developer and end-user the opportunity to attach attributes
with a few different mechanisms - and all will be suppressed
from normal view, unless specifically called upon.
What makes an xtsAttribute special is that it
is principally a mechanism to store and view meta-data, that is,
attributes that would be seen with a call to R's
{\tt attributes}.
<>=
str(attributes(matrix_xts))
str(xtsAttributes(matrix_xts))
# attach some attributes
xtsAttributes(matrix_xts) <- list(myattr="my meta comment")
attr(matrix_xts, 'another.item') <- "one more thing..."
str(attributes(matrix_xts))
str(xtsAttributes(matrix_xts))
@
In general - the only attributes that should be
handled directly by the user (\emph{without} the assistance
of xts functions) are ones returned by {\tt xtsAttributes}.
The additional attributes seen in the {\tt attributes}
example are for internal R and xts use, and if you expect
unbroken code, should be left alone.
\subsection{Subclassing {\tt xts}}
Subclassing xts is as simple as extending any other
S3 class in R. Simply include the full class of
the xts system in your new class.
<>=
xtssubclass <- structure(matrix_xts, class=c('xts2','xts','zoo'))
class(xtssubclass)
@
This will allow the user to override methods of xts and zoo,
while still allowing for backward compatibility with
all the tools of xts and zoo, much the way {\tt xts} benefits from
extending {\tt zoo}.
\section{Conclusion}
The {\tt xts} package offers both R developers and R users
an extensive set of time-aware tools for use in
time-based applications. By extending the {\tt zoo} class,
xts leverages an excellent infrastructure tool into
a true time-based class. This simple requirement for
time-based indexing allows for code to
make assumptions about the object's purpose, and facilitates
a great number of useful utilities --- such as time-based
subsetting.
Additionally, by embedding knowledge of the currently
used time-based classes available in R, xts can offer
the developer and end-user a single interface mechanism
to make internal class decisions user-driven. This
affords developers an opportunity to design applications
for there intended purposes, while freeing up time
previously used to manage the data structures.
Future development of xts will focus on integrating
xts into more external packages, as well as additional useful
additions to the time-based utilities currently available
within the package. An effort to provide external disk and
memory based data access will also be examined for potential
inclusion or extension.
\begin{thebibliography}{99}
\bibitem{zoo} Achim Zeileis and Gabor Grothendieck (2005):
\emph{ zoo: S3 Infrastructure for Regular and Irregular Time Series.}
Journal of Statistical Software, 14(6), 1-27. URL http://www.jstatsoft.org/v14/i06/
\bibitem{tseries} Adrian Trapletti and Kurt Hornik (2007):
\emph{tseries: Time Series Analysis and Computational Finance.} R package version 0.10-11.
\bibitem{rmetrics} Diethelm Wuertz, many others and see the SOURCE file (2007):
\emph{Rmetrics: Rmetrics - Financial Engineering and Computational Finance.}
R package version 260.72. http://www.rmetrics.org
\bibitem{ISO} International Organization for Standardization (2004):
\emph{ISO 8601: Data elements and interchage formats ---
Information interchange --- Representation of dates and time}
URL http://www.iso.org
\bibitem{R} R Development Core Team:
\emph{R: A Language and Environment for Statistical Computing},
R Foundation for Statistical Computing, Vienna, Austria.
ISBN 3-900051-07-0, URL http://www.R-project.org
\bibitem{quantmod} Jeffrey A. Ryan (2008):
\emph{quantmod: Quantitative Financial Modelling Framework.}
R package version 0.3-5. URL http://www.quantmod.com
URL http://r-forge.r-project.org/projects/quantmod
\end{thebibliography}
\end{document}
xts/vignettes/xts-faq.Rnw 0000644 0001762 0000144 00000030054 14634167654 015175 0 ustar ligges users %\documentclass[article,nojss]{jss}
%\DeclareGraphicsExtensions{.pdf,.eps}
%%\newcommand{\mysection}[2]{\subsubsection[#2]{\textbf{#1}}}
%\let\mysection=\subsubsection
%\renewcommand{\jsssubsubsec}[2][default]{\vskip \preSskip%
% \pdfbookmark[3]{#1}{Subsubsection.\thesubsubsection.#1}%
% \refstepcounter{subsubsection}%
% {\large \textbf{\textit{#2}}} \nopagebreak
% \vskip \postSskip \nopagebreak}
%% -*- encoding: utf-8 -*-
%\VignetteIndexEntry{xts FAQ}
%\VignetteDepends{zoo}
\documentclass{article}
%
\usepackage{Rd}
\usepackage{Sweave}
\usepackage{hyperref}
\hypersetup{colorlinks,%
citecolor=black,%
linkcolor=blue,%
urlcolor=blue,%
}
%%\encoding{UTF-8}
%%\usepackage[UTF-8]{inputenc}
%
\newcommand{\q}[1]{\section*{#1}\addcontentsline{toc}{subsection}{#1}}
\author{xts Deveopment Team%
\footnote{Contact author: Joshua M. Ulrich \email{josh.m.ulrich@gmail.com}}
\footnote{Thanks to Alberto Giannetti and Michael R. Weylandt for their many contributions.}
}
\title{\bf xts FAQ}
%\Keywords{irregular time series, time index, daily data, weekly data, returns}
%\Abstract{
% This is a collection of frequently asked questions (FAQ) about the
% \pkg{xts} package together with their answers.
%}
\begin{document}
\SweaveOpts{concordance=TRUE, engine=R, eps=FALSE}
%\SweaveOpts{engine=R, eps=FALSE}
<>=
library("xts")
Sys.setenv(TZ="GMT")
@
\makeatletter
\makeatother
\maketitle
\tableofcontents
\q{What is \pkg{xts}?}
%
\pkg{xts} is an \pkg{R} package offering a number of functionalities to work on
time-indexed data. \pkg{xts} extends \pkg{\pkg{zoo}}, another popular package
for time-series analysis.
% should point to the zoo FAQ here (or at some early point)
\q{Why should I use \pkg{xts} rather than \pkg{zoo} or another time-series
package?}
%
The main benefit of \pkg{xts} is its seamless compatibility with other packages
using different time-series classes (\pkg{timeSeries}, \pkg{zoo}, ...). In
addition, \pkg{xts} allows the user to add custom attributes to any object. See
the main \pkg{xts} vignette for more information.
\q{How do I install \pkg{xts}?}
%
\pkg{xts} depends on \pkg{zoo} and suggests some other packages. You should be
able to install \pkg{xts} and all the other required components by simply
calling \code{install.packages('pkg')} from the \pkg{R} prompt.
\q{I have multiple .csv time-series files that I need to load in a single
\pkg{xts} object. What is the most efficient way to import the files?}
%
If the files have the same format, load them with \code{read.zoo} and
then call \code{rbind} to join the series together; finally, call \code{as.xts}
on the result. Using a combination of \code{lapply} and \code{do.call} can
accomplish this with very little code:
<>=
filenames <- c("a.csv", "b.csv", "c.csv")
sample.xts <- as.xts(do.call("rbind", lapply(filenames, read.zoo)))
@
\q{Why is \pkg{xts} implemented as a matrix rather than a data frame?}
%
\pkg{xts} uses a matrix rather than data.frame because:
\begin{enumerate}
\item \pkg{xts} is a subclass of \pkg{zoo}, and that's how \pkg{zoo} objects
are structured; and
\item matrix objects have much better performance than data.frames.
\end{enumerate}
\q{How can I simplify the syntax when referring to \pkg{xts} object column names?}
%
\code{with} allows you to use the colmn names while avoiding the full square
brackets syntax. For example:
<>=
lm(sample.xts[, "Res"] ~ sample.xts[, "ThisVar"] + sample.xts[, "ThatVar"])
@
can be converted to
<>=
with(sample.xts, lm(Res ~ ThisVar + ThatVar))
@
\q{How can I replace the zeros in an \pkg{xts} object with the last non-zero value
in the series?}
%
Convert the zeros to \code{NA} and then use \code{na.locf}:
<<>>=
sample.xts <- xts(c(1:3, 0, 0, 0), as.POSIXct("1970-01-01")+0:5)
sample.xts[sample.xts==0] <- NA
cbind(orig=sample.xts, locf=na.locf(sample.xts))
@
\q{How do I create an \pkg{xts} index with millisecond precision?}
%
Milliseconds in \pkg{xts} indexes are stored as decimal values. This example
builds an index spaced by 100 milliseconds, starting at the current system time:
<<>>=
data(sample_matrix)
sample.xts <- xts(1:10, seq(as.POSIXct("1970-01-01"), by=0.1, length=10))
@
\q{I have a millisecond-resolution index, but the milliseconds aren't
displayed. What went wrong?}
%
Set the \code{digits.secs} option to some sub-second precision. Continuing from
the previous example, if you are interested in milliseconds:
<<>>=
options(digits.secs=3)
head(sample.xts)
@
\q{I set \code{digits.sec=3}, but \pkg{R} doesn't show the values correctly.}
%
Sub-second values are stored with approximately microsecond precision. Setting
the precision to only 3 decimal hides the full index value in microseconds and
might be tricky to interpret depending how the machine rounds the millisecond
(3rd) digit. Set the \code{digits.secs} option to a value higher than 3 or
convert the date-time to numeric and use \code{print}'s \code{digits} argument,
or \code{sprintf} to display the full value. For example:
<<>>=
dt <- as.POSIXct("2012-03-20 09:02:50.001")
print(as.numeric(dt), digits=20)
sprintf("%20.10f", dt)
@
\q{I am using \code{apply} to run a custom function on my \pkg{xts} object.
Why does the returned matrix have different dimensions than the original one?}
%
When working on rows, \code{apply} returns a transposed version of the
original matrix. Simply call \code{t} on the returned matrix to restore the
original dimensions:
<>=
sample.xts.2 <- xts(t(apply(sample.xts, 1, myfun)), index(sample.xts))
@
\q{I have an \pkg{xts} object with varying numbers of observations per day (e.g.,
one day might contain 10 observations, while another day contains 20 observations).
How can I apply a function to all observations for each day?}
%
You can use \code{apply.daily}, or \code{period.apply} more generally:
<<>>=
sample.xts <- xts(1:50, seq(as.POSIXct("1970-01-01"),
as.POSIXct("1970-01-03")-1, length=50))
apply.daily(sample.xts, colMeans)
period.apply(sample.xts, endpoints(sample.xts, "days"), colMeans)
period.apply(sample.xts, endpoints(sample.xts, "hours", 6), colMeans)
@
\q{How can I process daily data for a specific time subset?}
%
First use time-of-day subsetting to extract the time range you want to work on (note
the leading \code{"T"} and leading zeros are required for each time in the range:
\code{"T06:00"}), then use \code{apply.daily} to apply your function to the subset:
<>=
apply.daily(sample.xts['T06:00/T17:00',], colMeans)
@
\q{How can I analyze my irregular data in regular blocks, adding observations
for each regular block if one doesn't exist in the origianl time-series object?}
%
Use \code{align.time} to round-up the indexes to the periods you are interested
in, then call \code{period.apply} to apply your function. Finally, merge the
result with an empty xts object that contains all the regular index values
you want:
<<>>=
sample.xts <- xts(1:6, as.POSIXct(c("2009-09-22 07:43:30",
"2009-10-01 03:50:30", "2009-10-01 08:45:00", "2009-10-01 09:48:15",
"2009-11-11 10:30:30", "2009-11-11 11:12:45")))
# align index into regular (e.g. 3-hour) blocks
aligned.xts <- align.time(sample.xts, n=60*60*3)
# apply your function to each block
count <- period.apply(aligned.xts, endpoints(aligned.xts, "hours", 3), length)
# create an empty xts object with the desired regular index
empty.xts <- xts(, seq(start(aligned.xts), end(aligned.xts), by="3 hours"))
# merge the counts with the empty object
head(out1 <- merge(empty.xts, count))
# or fill with zeros
head(out2 <- merge(empty.xts, count, fill=0))
@
\q{Why do I get a \pkg{zoo} object when I call \code{transform} on my
\pkg{xts} object?}
%
There's no \pkg{xts} method for \code{transform}, so the \pkg{zoo} method is
dispatched. The \pkg{zoo} method explicitly creates a new \pkg{zoo} object. To
convert the transformed object back to an \pkg{xts} object wrap the
\code{transform} call in \code{as.xts}:
<>=
sample.xts <- as.xts(transform(sample.xts, ABC=1))
@
You might also have to reset the index timezone:
<>=
tzone(sample.xts) <- Sys.getenv("TZ")
@
\q{Why can't I use the \code{\&} operator in \pkg{xts} objects when querying
dates?}
%
\code{"2011-09-21"} is not a logical vector and cannot be coerced to a logical
vector. See \code{?"\&"} for details.
\pkg{xts}' ISO-8601 style subsetting is nice, but there's nothing we can do to
change the behavior of \code{.Primitive("\&")}. You can do something like this
though:
<>=
sample.xts[sample.xts$Symbol == "AAPL" & index(sample.xts) == as.POSIXct("2011-09-21"),]
@
or:
<>=
sample.xts[sample.xts$Symbol == "AAPL"]['2011-09-21']
@
\q{How do I subset an \pkg{xts} object to only include weekdays (excluding
Saturday and Sundays)?}
%
Use \code{.indexwday} to only include Mon-Fri days:
<<>>=
data(sample_matrix)
sample.xts <- as.xts(sample_matrix)
wday.xts <- sample.xts[.indexwday(sample.xts) %in% 1:5]
head(wday.xts)
@
\q{I need to quickly convert a data.frame that contains the time-stamps in one
of the columns. Using \code{as.xts(Data)} returns an error. How do I build my
\pkg{xts} object?}
%
The \code{as.xts} function assumes the date-time index is contained in the
\code{rownames} of the object to be converted. If this is not the case, you
need to use the \code{xts} constructor, which requires two arguments: a
vector or a matrix carrying data and a vector of type \code{Date},
\code{POSIXct}, \code{chron}, \ldots, supplying the time index information.
If you are certain the time-stamps are in a specific column, you can use:
<<>>=
Data <- data.frame(timestamp=as.Date("1970-01-01"), obs=21)
sample.xts <- xts(Data[,-1], order.by=Data[,1])
@
If you aren't certain, you need to explicitly reference the column name that
contains the time-stamps:
<<>>=
Data <- data.frame(obs=21, timestamp=as.Date("1970-01-01"))
sample.xts <- xts(Data[,!grepl("timestamp",colnames(Data))],
order.by=Data$timestamp)
@
\q{I have two time-series with different frequency. I want to combine the data
into a single \pkg{xts} object, but the times are not exactly aligned. I want
to have one row in the result for each ten minute period, with the time index
showing the beginning of the time period.}
%
\code{align.time} creates evenly spaced time-series from a set of indexes,
\code{merge} ensure two time-series are combined in a single \pkg{xts} object
with all original columns and indexes preserved. The new object has one entry
for each timestamp from both series and missing values are replaced with
\code{NA}.
<>=
x1 <- align.time(xts(Data1$obs, Data1$timestamp), n=600)
x2 <- align.time(xts(Data2$obs, Data2$timestamp), n=600)
merge(x1, x2)
@
\q{Why do I get a warning when running the code below?}
<<>>=
data(sample_matrix)
sample.xts <- as.xts(sample_matrix)
sample.xts["2007-01"]$Close <- sample.xts["2007-01"]$Close + 1
#Warning message:
#In NextMethod(.Generic) :
# number of items to replace is not a multiple of replacement length
@
%
This code creates two calls to the subset-replacement function
\code{xts:::`[<-.xts`}. The first call replaces the value of \code{Close}
in a temporary copy of the first row of the object on the left-hand-side of
the assignment, which works fine. The second call tries to replace
the first \emph{element} of the object on the left-hand-side of the
assignment with the modified temporary copy of the first row. This is
the problem.
For the command to work, there needs to be a comma in the first
subset call on the left-hand-side:
<>=
sample.xts["2007-01",]$Close <- sample.xts["2007-01"]$Close + 1
@
This isn't encouraged, because the code isn't clear. Simply remember to
subset by column first, then row, if you insist on making two calls to
the subset-replacement function. A cleaner and faster solution is below.
It's only one function call and it avoids the \code{\$} function (which
is marginally slower on xts objects).
<>=
sample.xts["2007-01","Close"] <- sample.xts["2007-01","Close"] + 1
@
%%% What is the fastest way to subset an xts object?
\end{document}
xts/data/ 0000755 0001762 0000144 00000000000 14703504524 012005 5 ustar ligges users xts/data/sample_matrix.rda 0000644 0001762 0000144 00000012041 14522244665 015346 0 ustar ligges users ‹ …˜y8UëÛÇM™24Sš‹H…=¡¤»’µVQ4BŠ¢L%
ÒtŠTTN"Ê¡‰TÆ’(S¦’ÊB
‹”÷î÷žÎº®žß{½°özöÚkÝë¹?ûó|×^mhΑ6—Çÿ¢øRLÿ ’¬‡‹»³ƒ‹Ýî]Nûð9ü{Ì¥¿ªýÔ€™t¤yÑÝñÀðßU닊£YR¢œæÌ#yQ`F}[Öã
Œ˜Q¯÷ ‡Í]