xts/0000755000176200001440000000000013611112162011062 5ustar liggesusersxts/NAMESPACE0000644000176200001440000001405213564762102012317 0ustar liggesusers# load symbol table useDynLib(xts) # non-base package imports importFrom(stats, lag, time, sd, median, na.omit, na.action, na.pass, start, end, window, ts, as.ts, frequency, tsp, 'tsp<-') importFrom(methods, hasArg) importFrom(grDevices, xy.coords) importFrom(graphics, abline, legend, lines, par, plot, plot.new, polygon, segments, text) importFrom(utils, str) # xts exports export(.parseISO8601) export(firstof, lastof) export(is.timeBased, timeBased, timeBasedRange, timeBasedSeq) export(.indexsec, .indexmin, .indexhour, .indexday, .indexDate, .indexmon, .indexmday, .indexwday, .indexyday, .indexisdst, .indexyear, .indexweek) export(isOrdered) export(.subset.xts) export(.subset_xts) # user visible core xts functions export(xts, .xts) export(as.xts) export(is.xts) export(endpoints) export(align.time) export(shift.time) export(adj.time) export(make.index.unique) export(make.time.unique) export(is.time.unique) export(is.index.unique) export(dimnames.xts) export('dimnames<-.xts') export(xcoredata) export('xcoredata<-') export(.index) export('.index<-') export(xtsible) export(as.environment.xts) export(use.xts, try.xts) export(Reclass, use.reclass) export(reclass) export(CLASS) export('CLASS<-') export(indexFormat) export('indexFormat<-') export(tformat) export('tformat<-') export(indexClass) export('indexClass<-') export(tclass) export('tclass<-') export(indexTZ) export('indexTZ<-') export(tzone) export('tzone<-') export(convertIndex) export(nseconds, nminutes, nhours, ndays, nweeks, nmonths, nquarters, nyears) export(to_period) # testing export(to.period, to.minutes, to.minutes3, to.minutes5, to.minutes10, to.minutes15, to.minutes30, to.hourly, to.daily, to.weekly, to.monthly, to.quarterly, to.yearly) export(xtsAttributes) export('xtsAttributes<-') export(periodicity) export(period.apply, period.max, period.min, period.sum, period.prod) export(first, last) export(apply.daily, apply.weekly, apply.monthly, apply.quarterly, apply.yearly) export(rbind.xts, cbind.xts, c.xts) export(split.xts) export(axTicksByTime) export(plot.xts) export(addLegend) export(addEventLines) # export(addPoints) export(addSeries) export(addPanel) export(addPolygon) S3method(plot,xts) S3method(lines,xts) S3method(points,xts) S3method(print, replot_xts) S3method(plot, replot_xts) #export(lines.xts) #S3method(lines,xts) #S3method(points,xts) #export(Lag.xts, Next.xts) #, Diff.xts) export(lag.xts) export(diff.xts) export(merge.xts) #export(mergeXts) S3method(all.equal, xts) S3method(split, xts) S3method(lag,xts) S3method(diff,xts) S3method(first,default) S3method(last,default) S3method(first,xts) S3method(last,xts) S3method(print,periodicity) S3method(align.time, xts) S3method(align.time, POSIXct) S3method(align.time, POSIXlt) S3method(shift.time, xts) S3method(make.index.unique, xts) S3method(make.index.unique, numeric) S3method(make.index.unique, POSIXct) S3method(is.time.unique, xts) S3method(is.time.unique, zoo) # xts methods importFrom(zoo,coredata) importFrom(zoo, index) importFrom(zoo,'index<-') importFrom(zoo,'time<-') importFrom(zoo, na.locf) importFrom(zoo, as.zoo) #importFrom(zoo, lagts) importFrom(zoo, rollapply) importFrom(zoo, na.approx) importFrom(zoo, na.fill) importFrom(zoo, as.yearmon) importFrom(zoo, as.yearqtr) importFrom(zoo, is.regular) importFrom(zoo, zoo) importFrom(zoo, MATCH) S3method(coredata,xts) S3method(xcoredata,default) S3method('xcoredata<-',default) S3method(as.xts,xts) S3method('[',xts) S3method('[<-',xts) S3method(str,xts) S3method(start, xts) S3method(end, xts) S3method(na.omit,xts) S3method(na.locf,xts) S3method(print,xts) S3method(print,CLASS) S3method('CLASS<-',xts) S3method(window,xts) S3method(dimnames, xts) S3method('dimnames<-', xts) S3method(tclass,xts) S3method('tclass<-',xts) S3method(tformat,xts) S3method('tformat<-',xts) S3method(tzone, default) S3method('tzone<-', default) S3method(tzone,xts) S3method('tzone<-',xts) S3method('index',xts) S3method('index<-',xts) S3method('time<-',xts) S3method('xtsAttributes<-',xts) S3method(merge,xts) S3method(rbind,xts) S3method(cbind,xts) S3method(c,xts) S3method(Ops,xts) S3method(as.numeric,xts) S3method(as.xts,numeric) S3method(as.double,xts) S3method(as.xts,double) S3method(as.integer,xts) S3method(as.xts,integer) S3method(as.complex,xts) S3method(as.xts,complex) S3method(as.logical,xts) S3method(as.xts,logical) S3method(cumsum, xts) S3method(cumprod, xts) S3method(cummin, xts) S3method(cummax, xts) #S3method(lagts,xts) S3method(rollapply, xts) # list specific methods S3method(as.list,xts) # ts specific methods S3method(as.xts, ts) S3method(as.ts, xts) # zoo specific methods #importFrom(zoo,as.zoo) # now in zoo S3method(as.xts,zoo) if (getRversion() >= "3.6.0" && utils::packageVersion("zoo") < "1.8.5") { # xts:::as.zoo.xts was copied to zoo:::as.zoo.xts in zoo 1.8-5 S3method(zoo::as.zoo, xts) } # data.frame specific methods S3method(as.xts,data.frame) S3method(as.data.frame, xts) # matrix specific methods S3method(as.xts,matrix) S3method(as.matrix,xts) # environment specific methods #S3method(as.xts,environment) S3method(as.environment,xts) # timeSeries (package:timeSeries) specific methods if (getRversion() >= "3.6.0") { S3method(timeSeries::as.timeSeries, xts) } S3method(as.xts,timeSeries) # irts (package:tseries) specific methods S3method(as.xts,irts) # fts (package:fts) specific methods if (getRversion() >= "3.6.0") { S3method(fts::as.fts, xts) } S3method(as.xts,fts) # Date specific methods S3method(as.xts,Date) # POSIX specific methods S3method(as.xts,POSIXt) # yearmon/yearqtr specific methods S3method(as.xts,yearmon) S3method(as.xts,yearqtr) # timeDate specific methods S3method(as.xts,timeDate) ## currently unexported functions that _may_ be exported at some point #export(startof,endof,firstof,lastof) xts/data/0000755000176200001440000000000012473475737012024 5ustar liggesusersxts/data/sample_matrix.rda0000644000176200001440000001204112473475737015357 0ustar liggesusersy8UM24SH=VQ4BL% tTTN"ʡTƒ(SB κ{zk?|^mhΑ6RL ­]N9{ԀtyU닊YR#yQ`F}[ Q]8 ~fQ+oe𾔭q[fvS9缀pzj0w08kN 0 oWtꤪ$['=Hx&q魱k۟$S%XǭÏRY*ӷv$0Vs\fѴ",umcu@VU1.lպ&Dz J!_bpX  K/7;f h`BKN9̍ar2oWF`6K7%l7n?E/MU``lU ?;}:0Ket:t<cMwN̘e1Ge˝@nqn3p Ϋơ@Ho; [}ߝ z|m:j @?7:L]qR:^xST[Տ6?ڴ h԰F( T3Ralˎ&seW;Π@{m9d2^vG|ɠ@5orsBlV>R-  `/쮤4Q= -7~x:;􁮟0sI tm[Q|?rLÚm];]ON r۴%MR?b+Y̬ɯ*O΢.3xt [:OhE+g0~ú.Pt}8YW.ՒT N5@?꫞ =PHc~,IM:bq/42Gs@KL80z@ 2Р I@U,sr]9@o؇V]철lzL0=5hap>P=vvkU!dL&PܯmX?GJGcjD<ӽMܳ9׬e5Gi+f\:4:r5O؀7{!`ee ՄX{C g Z[z]ElAb`<s;Y+/^׿l̙ʩRڪdLeǚT`O Zk`0Jƒopf^*dB#q/qsF;)qh\؛00$題w)ٚ.1ϞP~M|Y艜׳l.}\k1s1{s Y?W=2jR3GQ8~pNGz>P/.ȕ@[\(kNw=rw@Yf~xw-*X?W?sMHDO\ ꝬtǑsj%PezƊa\GES7oj`짴crglEAqgb,{mdn+U#q?p=κ1/p>ty1_c*Mng?]U7KzfϷ_{bߒ%Aw$xK&<t !9-+GZϛ~:*ΐa}`o? zq{"%];n.:uOi6qtd—r`y_Lc\#NbwMӾ8f5+Nsj?іE9%Qz"Tk@\g) u%QQ[mO{]FUw}qR@(Dn4zLp6?3|]om6?{:Ի7d-^O+)NƉ~Z\*(\z>?D+(IfX;~݂C1!S"o|†Sl/1}?Rbn٭duzi"@߰ʫK ,}&m4ƈqo25kWe+mm-l=ꥑ=^W=@ Ioz&_3uWA@ooX4z$jUes&!6?7vd>YTK"17w[l4ho D|U淹qzg-fgtys$,\iЕ_c4P1Bπ$l֊*h Tn9wv|̝Jz~S^ F.ŹG;bCjkύȟ>WxKﺧ[伢M$+?<)rKs(̃ߓg\ ;ܸx5rzv6}\!ܒ:i2&OMjڿ50-g>y۝䪴;=jmg߫sgN"ۿؤOY?ovRg+ơKnLl4g "[ȭqXʢv*8>Q:q̛W6s_@*o˪j;]~qQY'լ܆ٚ=꬟̃".Ԇ574ˇ%In]ǬwkER/.%󬃺N/7cdUz ܢhWtWKϷz̝ ޮF=4_Q!OAoKEԕIVӃ&U{ԡm̈{/az𵙸.uݦl=syo)MTr4@3 l~~^ZR+Db.-R6,;Km?Lx,(e\sTy z~> WAO?y~'?60#E/1.G+dV5|6~7zrƺ뭬˭|5L\Z~̈́yna=%ѯ;m 3w^+? c3=y[s`\)ܦ"爰~g4$ssGqRy5XV}E\~V߱~!xq9--Zs8#|bD@#Ĉ#ZĈ61BԬMԬMԬMԬMԬMԬMԬM!j5s9DfQ3C!j5sAbCp1'FĈ1K>;-A C!hpZ8-A C!hpZ8-A ;;;;;;;;;;;;;;;;;;;;;;;;;;;wKp Kp KZx-<A G#hZx-<A G#hZx-<A G#hZx-<A G'l 6| >`O'l 6| >`O'l 6| >`O'l 6| awZ-AE@" hZ-AE@" hZ-AE@" hZ-AE|^U^Ny-j#:y8?S0[#xts/man/0000755000176200001440000000000013607327605011654 5ustar liggesusersxts/man/timeBasedSeq.Rd0000644000176200001440000000660113564762102014511 0ustar liggesusers\name{timeBasedSeq} \alias{timeBasedSeq} \alias{timeBasedRange} \title{ Create a Sequence or Range of Times } \description{ A function to create a vector of time-based objects suitable for indexing an \emph{xts} object, given a string conforming to the ISO 8601 time and date standard for range-based specification. The resultant series can be of any class supported by \emph{xts}, including POSIXct, Date, chron, timeDate, yearmon, and yearqtr. \code{timeBasedRange} creates a vector of length 1 or 2 as seconds since the epoch (1970-01-01) for use internally. } \usage{ timeBasedSeq(x, retclass = NULL, length.out = NULL) timeBasedRange(x, ...) } \arguments{ \item{x}{ a string representing the time-date range desired } \item{retclass}{ the return class desired } \item{length.out}{ passed to \code{seq} internally } \item{\ldots}{ unused } } \details{ Designed to provide uniform creation of valid time-based objects for use within \emph{xts}, the interface conforms (mostly) to the ISO recommended format for specifying ranges. In general, the format is a string specifying a time and/or date \emph{from}, \emph{to}, and optionally \emph{by} delineated by either \sQuote{"/"} or \sQuote{"::"}. The first argument need not be quoted, as it is converted internally if need be. The general form is \emph{from/to/by} or \emph{from::to::by}, where \emph{to} and \emph{by} are optional if the length.out arg is specified. The \code{from} and \code{to} elements of the string must be left-specified with respect to the standard \emph{CCYYMMDD HHMMSS} form. All dates-times specified will be set to either the earliest point (from) or the latest (to), given the level of specificity. For example \sQuote{1999} in the \emph{from} field would set the start to the beginning of 1999. The opposite occurs in the \emph{to} field. The level of detail in the request is interpretted as the level of detail in the result. The maximum detail of either \emph{from} or \emph{to} is the basis of the sequence, unless the optional \emph{by} element is specified, which will be covered later. To request a yearly series, it is only necessary to use \sQuote{"1999/2008"}. Alternately, one could request a monthly series (returned by default as class \code{yearmon}) with \sQuote{"199901/2008"} or \sQuote{"1999-01/2008"}, or even \sQuote{"1999/2008-01"}. As the level of granularity increases, so does the resultant sequence granularity - as does its length. Using the optional third \emph{by} field (the third delimited element to the string), will override the granularity intepretation and return the requested periodicity. The acceptable arguments include \code{Y} for years, \code{m} for months, \code{d} for days, \code{H} for hours, \code{M} for minutes and \code{S} for seconds. } \value{ A sequence or range of time-based objects. If \code{retclass} is \code{NULL}, the result is a named list of from, to, by and length.out. } \references{ International Organization for Standardization: ISO 8601 \url{https://www.iso.org}} \author{ Jeffrey A. Ryan } \seealso{ \code{\link{timeBased}}, \code{\link{xts}} } \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 } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ utilities } xts/man/subset.xts.Rd0000644000176200001440000001122313564762102014261 0ustar liggesusers\name{[.xts} \Rdversion{1.1} \alias{[.xts} \alias{subset.xts} \alias{.subset.xts} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Extract Subsets of xts Objects } \description{ Details on efficient subsetting of \code{xts} objects for maximum performance and compatibility. } \usage{ \method{[}{xts}(x, i, j, drop = FALSE, which.i=FALSE, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ xts object } \item{i}{ the rows to extract. Numeric, timeBased or ISO-8601 style (see details) } \item{j}{ the columns to extract, numeric or by name } \item{drop}{ should dimension be dropped, if possible. See NOTE. } \item{which.i}{ return the \sQuote{i} values used for subsetting. No subset will be performed. } \item{\dots}{ additional arguments (unused) } } \details{ One of the primary motivations, and key points of differentiation of the time series class 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 time object used in construction. When a raw character vector is used for the \code{i} subset argument, it is processed as if it was ISO-8601 compliant. This means that it is parsed from left to right, according to the following specification: CCYYMMDD HH:MM:SS.ss+ A full description will be expanded from a left-specified truncated one. Additionally, one may specify range-based queries by simply supplying two time descriptions seperated by a forward slash: CCYYMMDD HH:MM:SS.ss+/CCYYMMDD HH:MM:SS.ss The algorithm to parse the above is \code{.parseISO8601} from the \pkg{xts} package. ISO-style subsetting, given a range type query, makes use of a custom binary search mechanism that allows for very fast subsetting as no linear search though the index is required. ISO-style character vectors may be longer than length one, allowing for multiple non-contiguous ranges to be selected in one subsetting call. If a character \emph{vector} representing time is used in place of numeric values, ISO-style queries, or timeBased objects, the above parsing will be carried out on each element of the i-vector. This overhead can be very costly. If the character approach is used when no ISO range querying is needed, it is recommended to wrap the \sQuote{i} character vector with the \code{I()} function call, to allow for more efficient internal processing. Alternately converting character vectors to POSIXct objects will provide the most performance efficiency. As \code{xts} uses POSIXct time representations of all user-level index classes internally, the fastest timeBased subsetting will always be from POSIXct objects, regardless of the \code{tclass} of the original object. All non-POSIXct time classes are converted to character first to preserve consistent TZ behavior. } \value{ An extraction of the original xts object. If \code{which.i} is TRUE, the corresponding integer \sQuote{i} values used to subset will be returned. } \note{ By design, drop=FALSE in the default case. This preserves the basic underlying type of \code{matrix} and the \code{dim()} to be non-NULL. This is different from both matrix and \code{zoo} behavior as \R uses \code{drop=TRUE}. Explicitly passing \code{drop=TRUE} may be required when performing certain matrix operations. } \references{ ISO 8601: Date elements and interchange formats - Information interchange - Representation of dates and time \url{https://www.iso.org} } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{xts}}, \code{\link{.parseISO8601}}, } \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) } \keyword{ utilities } xts/man/xts-package.Rd0000644000176200001440000000161513564762102014352 0ustar liggesusers\name{xts-package} \alias{xts-package} \docType{package} \title{ xts: extensible time-series } \description{ Extensible time series class and methods, extending and behaving like zoo. } \details{ \tabular{ll}{ Package: \tab xts\cr Type: \tab Package\cr Version: \tab 0.10-2\cr Date: \tab 2018-03-13\cr License: \tab GPL (>= 2)\cr } 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. } \author{ Jeffrey A. Ryan and Joshua M. Ulrich Maintainer: Joshua M. Ulrich } \keyword{ package } \seealso{ \code{\link{xts}} \code{\link{as.xts}} \code{\link{reclass}} \code{\link[zoo:zoo]{zoo}} } xts/man/xtsAttributes.Rd0000644000176200001440000000237212473475737015046 0ustar liggesusers\name{xtsAttributes} \alias{xtsAttributes} \alias{xtsAttributes<-} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Extract and Replace xts Attributes } \description{ Extract and replace non-core \code{xts} attributes. } \usage{ xtsAttributes(x, user=NULL) xtsAttributes(x) <- value } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ an xts object } \item{user}{ logical; should user-defined attributes be returned? The default of \code{NULL} returns all \code{xts} attributes. } \item{value}{ a list of new name=value attributes } } \details{ Since \code{xts} objects are S3 objects with special attributes, a method is necessary to properly assign and view the user-added attributes. A call to \code{attributes} from the \pkg{base} package will return all attributes, including those specific to the \code{xts} class. } \value{ A named list of user settable attributes. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{attributes}}} \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) } \keyword{ utilities } xts/man/diff.Rd0000644000176200001440000000533512530101636013045 0ustar liggesusers\name{diff.xts} \alias{diff.xts} \alias{lag.xts} \alias{lagts.xts} \title{ Lags and Differences of xts Objects } \description{ Methods for computing lags and differences on \code{xts} objects. This matches most of the functionality of \pkg{zoo} methods, with some default argument changes. } \usage{ \method{lag}{xts}(x, k = 1, na.pad = TRUE, ...) %\method{lagts}{xts}(x, k = 1, na.pad = TRUE, ...) % \method{diff}{xts}(x, lag = 1, differences = 1, arithmetic = TRUE, log = FALSE, na.pad = TRUE, ...) } \arguments{ \item{x}{ an \code{xts} object } \item{k}{ period to lag over } \item{lag}{ period to difference over } \item{differences}{ order of differencing } \item{arithmetic}{ should arithmetic or geometric differencing be used } \item{log}{ should (geometric) log differences be returned } \item{na.pad}{ pad vector back to original size } \item{\dots}{ additional arguments } } \details{ The primary motivation for having methods specific to \code{xts} was to make use of faster C-level code within xts. Additionally, it was decided that \code{lag}'s default behavior should match the common time-series interpretation of that operator --- specifically that a value at time \sQuote{t} should be the value at time \sQuote{t-1} for a positive lag. This is different than \code{lag.zoo} as well as \code{lag.ts}. Another notable difference is that \code{na.pad} is set to TRUE by default, to better reflect the transformation visually and within functions requiring positional matching of data. Backwards compatability with zoo can be achieved by setting \code{options(xts.compat.zoo.lag=TRUE)}. This will change the defaults of lag.xts to k=-1 and na.pad=FALSE. %With the introduction of the new \code{lagts} generic in zoo, lag.xts %will begin the process of reverting to zoo-behavior, i.e. negative %k values will indicate positive lags. The current xts behavior will %then move to lagts. The process by which this will happen will be %a warning displayed in any lag.xts call at first, calling attention %to the upcoming change. The new xts method for lagts will be be made available %as of 0.8-1. Warning messages of the change will follow in subsequent releases. } \value{ An \code{xts} object reflected the desired lag and/or differencing. } \references{ \url{http://en.wikipedia.org/wiki/Lag } } \author{ Jeffrey A. Ryan } \examples{ x <- xts(1:10, Sys.Date()+1:10) lag(x) # currently using xts-style positive k %lagts(x) # same as original lag.xts, to allow for lag.xts to revert to R lag consistency lag(x, k=2) %lagts(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)) } \keyword{ manip }% __ONLY ONE__ keyword per line \keyword{ chron }% __ONLY ONE__ keyword per line xts/man/CLASS.Rd0000644000176200001440000000160612473475737013025 0ustar liggesusers\name{CLASS} \alias{CLASS} \alias{CLASS<-} \title{ Extract and Set .CLASS Attribute } \description{ Simple extraction and replacement function to access \code{xts} .CLASS attribute. The .CLASS attribute is used by \code{reclass} to transform an \code{xts} object back to its original class. } \usage{ CLASS(x) CLASS(x) <- value } \arguments{ \item{x}{ an xts object } \item{value}{ the new .CLASS value to assign } } \details{ It is not recommended that CLASS be called in daily use. While it may be possible to coerce objects to other classes than originally derived from, there is little, if any, chance that the \code{reclass} function will perform as expected. It is best to use the traditional \code{as} methods. } \value{ Called for its side-effect of changing the .CLASS attribute } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{as.xts}},\code{\link{reclass}} } \keyword{ utilities } xts/man/isOrdered.Rd0000644000176200001440000000157712473475737014107 0ustar liggesusers\name{isOrdered} \alias{isOrdered} \title{ Check If A Vector Is Ordered } \description{ Performs check to determine if a vector is strictly increasing, strictly decreasing, not decreasing, or not increasing. } \usage{ isOrdered(x, increasing = TRUE, strictly = TRUE) } \arguments{ \item{x}{ a numeric vector } \item{increasing}{ test for increasing/decreasing values } \item{strictly}{ are duplicates OK } } \details{ Designed for internal use with \pkg{xts}, this provides highly optimized tests for ordering. } \value{ Logical } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{is.unsorted}} } \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) } \keyword{ misc } xts/man/ndays.Rd0000644000176200001440000000214612473475737013276 0ustar liggesusers\name{ndays} \alias{nseconds} \alias{nminutes} \alias{nhours} \alias{ndays} \alias{nweeks} \alias{nmonths} \alias{nquarters} \alias{nyears} \title{ Number of Periods in Data } \description{ Calculate the number of specified periods in a given time series like data object. } \usage{ nseconds(x) nminutes(x) nhours(x) ndays(x) nweeks(x) nmonths(x) nquarters(x) nyears(x) } \arguments{ \item{x}{ A time-based object } } \details{ Essentially a wrapper to \code{endpoints} with the appropriate period specified; the resulting value derived from counting the endpoints As a compromise between simplicity and accuracy, the results will always round up to the nearest complete period. So n**** - 1 will return the completed periods. For finer grain detail one should call a higher frequency n**** function. An alternative summary can be found with \code{periodicity} and \code{unclass(periodicity(x))}. } \value{ The number of observations for the period type specified } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{endpoints}} } \examples{ \dontrun{ getSymbols("QQQQ") ndays(QQQQ) nweeks(QQQQ) } } \keyword{ utilities } xts/man/merge.Rd0000644000176200001440000000711513564762102013243 0ustar liggesusers\name{merge.xts} \alias{merge.xts} \alias{cbind.xts} \title{ Merge xts Objects } \description{ Used to perform merge operation on \code{xts} objects by \emph{time} (index). Given the inherent ordered nature of \code{xts} time-series, a merge-join style merge allows for optimally efficient joins. } \usage{ \method{merge}{xts}(..., all = TRUE, fill = NA, suffixes = NULL, join = "outer", retside = TRUE, retclass = "xts", tzone = NULL, drop=NULL, check.names=NULL) } \arguments{ \item{\dots}{ one or more xts objects, or objects coercible to class xts } \item{all}{ a logical vector indicating merge type } \item{fill}{ values to be used for missing elements } \item{suffixes}{ to be added to merged column names } \item{join}{ type of database join } \item{retside}{ which side of the merged object should be returned (2-case only) } \item{retclass}{ object to return } \item{tzone}{ time zone of merged object } \item{drop}{ not currently used } \item{check.names}{ not currently used } } \details{ This is an xts method compatible with merge.zoo, as xts extends zoo. That documentation should also be referenced. Difference are noted where applicable. Implemented almost entirely in custom C-level code, it is possible using either the \code{all} argument or the \code{join} argument to implement all common database join operations along the to-be-merged objects time-index: \sQuote{outer} (full outer - all rows), \sQuote{inner} (only rows with common indexes), \sQuote{left} (all rows in the left object, and those that match in the right), and \sQuote{right} (all rows in the right object, and those that match in the left). The above join types can also be expressed as a vector of logical values passed to \code{all}. c(TRUE,TRUE) or TRUE for \sQuote{join="outer"}, c(FALSE,FALSE) or FALSE for \sQuote{join="inner"}, c(TRUE, FALSE) for \sQuote{join="left"}, and c(FALSE,TRUE) for \sQuote{join="right"}. Note that the \code{all} and \code{join} arguments imply a two case scenario. For merging more than two objects, they will simply fall back to a full outer or full inner join, depending on the first position of all, as left and right can be ambiguous with respect to sides. To do something along the lines of merge.zoo's method of joining based on an all argument of the same length of the arguments to join, see the example. The resultant object will have the timezone of the leftmost argument if available. Use \code{tzone} to override. If \code{retclass} is \code{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, though unused by xts. If \code{retclass} is \code{FALSE} the object will be stripped of its class attribute. This is for internal use. } \value{ A new \code{xts} object containing the appropriate elements of the objects passed in to be merged. } \references{ Merge Join Discussion: \url{https://blogs.msdn.microsoft.com/craigfr/2006/08/03/merge-join/} } \author{ Jeffrey A. Ryan } \note{ This is a highly optimized merge, specifically designed for ordered data. The only supported merging is based on the underlying time index. } \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) } \keyword{ manip } \keyword{ utilities } xts/man/as.xts.Rd0000644000176200001440000000700213564762102013357 0ustar liggesusers\name{as.xts} \alias{as.xts} \alias{xtsible} \alias{use.xts} \alias{try.xts} \alias{use.reclass} \alias{Reclass} \alias{reclass} \title{ Convert Object To And From Class xts } \description{ Conversion functions to coerce data objects of arbitrary classes to class \code{xts} and back, without losing any attributes of the original format. } \usage{ as.xts(x, ...) xtsible(x) Reclass(x) try.xts(x, ..., error = TRUE) reclass(x, match.to, error = FALSE, ...) } \arguments{ \item{x}{ data object to convert. See details for supported types } \item{match.to}{ \code{xts} object whose attributes will be passed to \code{x}} \item{error}{ error handling option. See Details. } \item{\dots}{ additional parameters or attributes } } \details{ A simple and reliable way to convert many different objects into a uniform format for use within \R. It is possible with a call to \code{as.xts} to convert objects of class \code{timeSeries}, \code{ts}, \code{irts}, \code{fts}, \code{matrix}, \code{data.frame}, and \code{zoo}. \code{xtsible} safely checks whether an object can be converted to an \code{xts} object; returning TRUE on success and FALSE otherwise. The help file \code{as.xts.methods} lists all available xts methods and arguments specific to each coercible type. Additional name=value pairs may be passed to the function to be added to the new object. A special print.xts method will assure that the attributes are hidden from view, but will be available via \R's standard \code{attr} function, as well as the \code{xtsAttributes} function. The returned object will preserve all relevant attribute/slot data within itself, allowing for temporary conversion to use zoo and xts compatible methods. A call to \code{reclass} returns the object to its original class, with all original attributes intact - unless otherwise changed. It should be obvious, but any attributes added via the \dots argument will not be carried back to the original data object, as there would be no available storage slot/attribute. \code{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 within \R are not designed to return objects matching the original object's class. While this tool is highly experimental at present, it attempts to handle conversion and reconversion transparently. The caveats are that the original object must be coercible to \code{xts}, the returned object must be of the same row length as the original object, and that the object to reconvert to is the first argument to the function being wrapped. \code{try.xts} and \code{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. The \code{error} argument to try.xts accepts a logical value, indicating where an error should be thrown, a character string allowing for custom error messages to be displayed, or a function of the form \code{f(x, ...)}, to be called upon construction error. See the accompanying vignette for more details on the above usage and the package in general. } \value{ An S3 object of class \code{xts}. In the case of \code{Reclass} and \code{reclass}, the object returned will be of the original class as identified by \code{CLASS}. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{xts}},\code{\link{as.xts.methods}} } \keyword{ utilities } xts/man/period.max.Rd0000644000176200001440000000222612473475737014225 0ustar liggesusers\name{period.max} \alias{period.max} \title{ Calculate Max By Period } \description{ Calculate a maximum for each period of INDEX. Essentially a rolling application of maximum over a series of non-overlapping sections. } \usage{ period.max(x, INDEX) } \arguments{ \item{x}{ a univariate data object } \item{INDEX}{ a numeric vector of endpoints to calculate maximum on } } \details{ Used to calculate a maximum per period given an arbitrary index of sections to be calculated over. This is an optimized function for maximum. There are additional optimized versions for min, sum, and prod. For xts-coercible objects, an appropriate INDEX can be derived from a call to 'endpoints'. } \value{ An xts or zoo object of maximums, indexed by the period endpoints. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{endpoints}}, \code{\link{period.sum}}, \code{\link{period.min}}, \code{\link{period.prod}} } \examples{ period.max(c(1,1,4,2,2,6,7,8,-1,20),c(0,3,5,8,10)) data(sample_matrix) period.max(sample_matrix[,1],endpoints(sample_matrix)) period.max(as.xts(sample_matrix)[,1],endpoints(sample_matrix)) } \keyword{ utilities }% __ONLY ONE__ keyword per line xts/man/addEventLines.Rd0000644000176200001440000000254713564762102014675 0ustar liggesusers\name{addEventLines} \alias{addEventLines} \title{Add vertical lines to an existing xts plot} \usage{ addEventLines(events, main = "", on = 0, lty = 1, lwd = 1, col = 1, ...) } \arguments{ \item{events}{xts object of events and their associated labels. It is assumed that the first column of \code{events} is the event description/label.} \item{main}{main title for a new panel if drawn.} \item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}. The default, \code{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 \code{on} is checked for the default behavior to add to the last active panel.} \item{lty}{set the line type, same as in \code{\link{par}}.} \item{lwd}{set the line width, same as in \code{\link{par}}.} \item{col}{color palette to use, set by default to rational choices.} \item{\dots}{any other passthrough parameters to \code{\link{text}} to control how the event labels are drawn} } \description{ Add vertical lines and labels to an existing xts plot } \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) } } xts/man/coredata.xts.Rd0000644000176200001440000000334212473475737014556 0ustar liggesusers\name{coredata.xts} \alias{coredata.xts} \alias{xcoredata} \alias{xcoredata<-} \title{ Extract/Replace Core Data of an xts Object } \description{ Mechanism to extract and replace the core data of an \code{xts} object. } \usage{ \method{coredata}{xts}(x, fmt=FALSE, ...) xcoredata(x,...) xcoredata(x) <- value } \arguments{ \item{x}{ an \code{xts} object } \item{fmt}{ should the rownames be formated in a non-standard way } \item{value}{ non-core attributes to assign } \item{\dots}{ further arguments [unused] } } \details{ Extract coredata of an \code{xts} object - removing all attributes except \code{dim} and \code{dimnames} and returning a matrix object with rownames converted from the index of the \code{xts} object. The \code{fmt} argument, if TRUE, allows the internal index formatting specified by the user to be used. Alternatively, it may be a valid formatting string to be passed to \code{format}. Setting to FALSE will return the row names by simply coercing the index class to a character string in the default manner. \code{xcoredata} is the functional complement to \code{coredata}, returning all of the attributes normally removed by \code{coredata}. Its purpose, along with the replacement function \code{xcoredata<-} is primarily for use by developers using \pkg{xts} to allow for internal replacement of values removed during use of non xts-aware functions. } \value{ 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{ \code{\link[zoo:zoo]{coredata}}, \code{\link{xtsAttributes}} } \examples{ data(sample_matrix) x <- as.xts(sample_matrix, myattr=100) coredata(x) xcoredata(x) } \keyword{ utilities } xts/man/parseISO8601.Rd0000644000176200001440000000574013564762102014152 0ustar liggesusers\name{.parseISO8601} \alias{ISO8601} \Rdversion{1.1} \alias{parseISO8601} \alias{makeISO8601} \alias{.parseISO8601} \alias{.makeISO8601} \title{ Internal ISO 8601:2004(e) Time Parser } \description{ This function is used internally in the subsetting mechanism of xts. The function is unexported, though documented for use with xts subsetting. } \usage{ .parseISO8601(x, start, end, tz="") .makeISO8601(x) } \arguments{ \item{x}{ For .parseISO8601(x), a character string conforming to the ISO 8601:2004(e) rules. For .makeISO8601(x), \code{x} should be a time-like object with \code{start} and \code{end} methods. } \item{start}{ lower constraint on range } \item{end}{ upper constraint of range } \item{tz}{ timezone (tzone) to use internally } } \details{ This function replicates most of the ISO standard for expressing time and time-based ranges in a universally accepted way. The best documentation is now 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 asPOSIXct 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. } \value{ A list of length two, with an entry named \sQuote{first.time} and one names \sQuote{last.time}. For .makeISO8601, a character vector of length one describing the ISO-style format for a given time-based object. } \references{ \url{https://en.wikipedia.org/wiki/ISO_8601}\cr \url{https://www.iso.org/iso-8601-date-and-time-format.html} } \author{ Jeffrey A. Ryan } \note{ There is no checking done to test for a properly constructed ISO format string. This must be correctly entered by the user, lest bad things may happen. 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, rather it is a standards and implementation gotcha. } \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') } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ utilities } xts/man/split.Rd0000644000176200001440000000267213564762102013302 0ustar liggesusers\name{split.xts} \Rdversion{1.1} \alias{split.xts} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Divide into Groups by Time } \description{ Creates a list of xts objects split along time periods. } \usage{ \method{split}{xts}(x, f = "months", drop=FALSE, k = 1, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ an xts object } \item{f}{ a 'character' vector describing the period to split by } \item{drop}{ ignored by split.xts } \item{k}{ number of periods to aggregate into each split. See Details. } \item{\dots}{ further args to non-xts method } } \details{ A quick way to break up a large xts object by standard time periods; e.g. 'months', 'quarters', etc. \code{endpoints} is used to find the start and end of each period (or k-periods). See that function for valid arguments. If \code{f} is not a character vector, the NextMethod is called, which would in turn dispatch to the split.zoo method. } \value{ A list of xts objects. } \author{ Jeffrey A. Ryan } \note{ \code{aggregate.zoo} would be more flexible, though not as fast for xts objects. } \seealso{ \code{\link{endpoints}}, \code{\link[zoo]{split.zoo}}, \code{\link[zoo]{aggregate.zoo}} } \examples{ data(sample_matrix) x <- as.xts(sample_matrix) split(x) split(x, f="weeks") split(x, f="weeks", k=4) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ utilities } xts/man/plot.xts.Rd0000644000176200001440000001261013564762102013733 0ustar liggesusers\name{plot.xts} \alias{plot.xts} \alias{lines.xts} \alias{points.xts} \title{Plotting xts Objects} \usage{ \method{plot}{xts}(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)), observation.based = FALSE, ylim = NULL, yaxis.same = TRUE, yaxis.left = TRUE, yaxis.right = TRUE, 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) \method{lines}{xts}(x, ..., main = "", on = 0, col = NULL, type = "l", lty = 1, lwd = 1, pch = 1) \method{points}{xts}(x, ..., main = "", on = 0, col = NULL, pch = 1) } \arguments{ \item{x}{xts object} \item{y}{NULL, not used} \item{\dots}{any passthrough graphical arguments for \code{lines} and \code{points}} \item{subset}{character vector of length one of the subset range using subsetting as in \code{\link{xts}}} \item{panels}{character vector of expressions to plot as panels} \item{multi.panel}{TRUE/FALSE or an integer less than or equal to the number of columns in the data set. If TRUE, each column of the data is plotted in a separate panel. For example, if \code{multi.panel = 2}, then the data will be plotted in groups of 2 columns and each group is plotted in a separate panel.} \item{col}{color palette to use, set by default to rational choices} \item{up.col}{color for positive bars if \code{type="h"}} \item{dn.col}{color for negative bars if \code{type="h"}} \item{bg}{background color of plotting area, same as in \code{\link{par}}} \item{type}{the type of plot to be drawn, same as in \code{\link{plot}}} \item{lty}{set the line type, same as in \code{\link{par}}} \item{lwd}{set the line width, same as in \code{\link{par}}} \item{lend}{set the line end style, same as in \code{\link{par}}} \item{main}{main title} \item{observation.based}{TRUE/FALSE (default FALSE). If \code{TRUE}, the x-axis is drawn based on observations in the data. If \code{FALSE}, the x-axis is drawn based on the time index of the data.} \item{ylim}{the range of the y axis} \item{yaxis.same}{TRUE/FALSE. If TRUE, the y axis is drawn with the same ylim for multiple panels} \item{yaxis.left}{if TRUE, draws the y axis on the left} \item{yaxis.right}{if TRUE, draws the y axis on the right} \item{major.ticks}{period that specifies where tick marks and labels will be drawn on the x-axis. See Details for possible values.} \item{minor.ticks}{period that specifies where minor ticks on will be drawn on the x-axis. If \code{NULL}, minor ticks are not drawn. See Details for possible values.} \item{grid.ticks.on}{period that specifies where vertical grid lines will be drawn. See Details for possible values.} \item{grid.ticks.lwd}{line width of the grid} \item{grid.ticks.lty}{line type of the grid} \item{grid.col}{color of the grid} \item{labels.col}{color of the axis labels} \item{format.labels}{label format to draw lower frequency x-axis ticks and labels passed to \code{\link{axTicksByTime}}} \item{grid2}{color for secondary x axis grid} \item{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.} \item{pch}{the plotting character to use, same as in \code{\link{par}}.} \item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}. The default, \code{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 \code{on} is checked for the default behavior to add to the last active panel.} } \details{ Possible values for arguments \code{major.ticks}, \code{minor.ticks}, and \code{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 \code{ticks.on} argument of \code{\link{axTicksByTime}}. } \description{ Plotting for xts objects. } \author{ Ross Bennett } \references{ based on \code{chart_Series} in the \code{quantmod} package by Jeffrey A. Ryan } \seealso{ \code{\link{addSeries}}, \code{\link{addPanel}} } \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")) } } xts/man/align.time.Rd0000644000176200001440000000256312530101636014164 0ustar liggesusers\name{align.time} \Rdversion{1.1} \alias{align.time} \alias{align.time.xts} \alias{adj.time} \alias{shift.time} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Align seconds, minutes, and hours to beginning of next period. } \description{ Change timestamps to the start of the next period, specified in multiples of seconds. } \usage{ align.time(x, ...) \method{align.time}{xts}(x, n=60, \dots) shift.time(x, n=60, ...) adj.time(x, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ object to align } \item{n}{ number of seconds to adjust by } \item{\dots}{ additional arguments. See details. } } \details{ This function is an S3 generic. The result is to round up to the next period determined by \code{n modulo x}. } \value{ A new object of class(x) } \author{ Jeffrey A. Ryan with input from Brian Peterson } \seealso{ \code{\link{to.period}} } \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) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ chron }% __ONLY ONE__ keyword per line \keyword{ manip }% __ONLY ONE__ keyword per line \keyword{ ts }% __ONLY ONE__ keyword per line \keyword{ misc }% __ONLY ONE__ keyword per line xts/man/window.xts.Rd0000644000176200001440000000464513564762102014275 0ustar liggesusers\name{window.xts} \Rdversion{1.1} \alias{window.xts} \title{Extract time windows from an \code{xts} series} \description{ Method for extracting time windows from \code{xts} objects. } \usage{ \method{window}{xts}(x, index. = NULL, start = NULL, end = NULL, \dots) } \arguments{ \item{x}{an object.} \item{index.}{a user defined time index. This defaults to the \code{xts} index for the series via \code{.index(x)}. When supplied, this is typically a subset of the dates in the full series.\cr The \code{index.} must be a set of dates that are convertible to \code{POSIXct}. If you want fast lookups, then \code{index.} should be sorted and of class \code{POSIXct}.\cr If an unsorted \code{index.} is passed in, \code{window} will sort it.} \item{start}{a start time. Extract \code{xts} rows where \code{index. >= start}. \code{start} may be any class that is convertible to \code{POSIXct} such as a character variable in the format \sQuote{YYYY-MM-DD}.\cr If \code{start} is \code{NULL} then all \code{index.} dates are matched.} \item{end}{an end time. Extract \code{xts} rows where \code{index. <= end}. \code{end} must be convertible to \code{POSIXct}. If \code{end} is \code{NULL} then all \code{index.} dates are matched.} \item{\dots}{currently not used.} } \value{ The matching time window is extracted. } \details{ The point of having \code{window} in addition to the regular subset function is to have a fast way of extracting time ranges from an \code{xts} series. In particular, this method will convert \code{start} and \code{end} to \code{POSIXct} then do a binary lookup on the internal \code{xts} index to quickly return a range of matching dates. With a user supplied \code{index.}, a similarly fast invocation of \code{findInterval} is used so that large sets of sorted dates can be retrieved quickly. } \author{ Corwin Joy } \seealso{ \code{\link{subset.xts}}, \code{\link[base]{findInterval}}, \code{\link{xts}} } \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 } \keyword{ts} xts/man/firstof.Rd0000644000176200001440000000171312473475737013633 0ustar liggesusers\name{firstof} \alias{firstof} \alias{lastof} \title{ Create a POSIXct Object } \description{ Enable fast creation of time stamps corresponding to the first or last observation in a specified time period. } \usage{ firstof(year = 1970, month = 1, day = 1, hour = 0, min = 0, sec = 0, tz = "") } %- maybe also 'usage' for other objects documented here. \arguments{ \item{year,month,day}{ numerical values to specify a day } \item{hour,min,sec}{ numerical vaues to specify time within a day } \item{tz}{ timezone used for conversion } } \details{ A wrapper to the \R function ISOdatetime with defaults corresponding to the first or last possible time in a given period. } \value{ An object of class POSIXct. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{ISOdatetime}} } \examples{ firstof(2000) firstof(2005,01,01) lastof(2007) lastof(2007,10) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ utilities } xts/man/make.index.unique.Rd0000644000176200001440000000351712530101636015465 0ustar liggesusers\name{make.index.unique} \alias{make.index.unique} \alias{make.time.unique} \alias{is.index.unique} \alias{is.time.unique} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Force Time Values To Be Unique } \description{ 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 \code{eps} is set to ten microseconds. In practice this advances each subsequent identical time by \code{eps} over the previous (possibly also advanced) value. } \usage{ make.index.unique(x, eps = 1e-06, drop=FALSE, fromLast=FALSE, ...) make.time.unique(x, eps = 1e-06, drop=FALSE, fromLast=FALSE, ...) } \arguments{ \item{x}{ An xts object, or POSIXct vector. } \item{eps}{ value to add to force uniqueness. } \item{drop}{ drop duplicates instead of adjusting by \code{eps} } \item{fromLast}{ if drop=TRUE, fromLast controls which duplicated times are dropped. If fromLast=FALSE, the earliest observation with an identical timestamp is kept with subsequent observations dropped. } \item{\dots}{ unused } } \details{ The returned time-series object will have new time-stamps so that \code{isOrdered( .index(x) )} evaluates to TRUE. } \value{ A modified version of x. } \author{ Jeffrey A. Ryan } \note{ Incoming values must be pre-sorted, and no check is done to make sure that this is the case. If the index values are of storage.mode \sQuote{integer}, they will be coerced to \sQuote{double} if drop=FALSE. } \seealso{ \code{\link{align.time}} } \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) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ ts } xts/man/first.Rd0000644000176200001440000000640012473475737013304 0ustar liggesusers\name{first} \alias{first} \alias{first.default} \alias{first.xts} \alias{last} \alias{last.default} \alias{last.xts} \title{ Return First or Last n Elements of A Data Object } \description{ A generic function 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. } \usage{ first(x,...) last(x,...) \method{first}{default}(x,n=1,keep=FALSE,...) \method{last}{default}(x,n=1,keep=FALSE,...) \method{first}{xts}(x,n=1,keep=FALSE,...) \method{last}{xts}(x,n=1,keep=FALSE,...) } \arguments{ \item{x}{ 1 or 2 dimensional data object } \item{n}{ number of periods to return } \item{keep}{ should removed values be kept? } \item{\dots}{ additional args - unused } } \details{ Provides the ability to identify the first or last \code{n} rows or observations of a data set. The generic method behaves much like \code{head} and \code{tail} from \pkg{base}, except by default only the \emph{first} or \emph{last} observation will be returned. The more useful method for the xts class allows for time based subsetting, given an xtsible object. \code{n} may be either a numeric value, indicating the number of observations to return - forward from \code{first}, or backwards from \code{last}, or it may be a character string describing the number and type of periods to return. \code{n} may be positive or negative, in either numeric or character contexts. When positive it will return the result expected - e.g. \code{last(X,'1 month')} will return the last month's data. If negative, all data will be returned \emph{except} for the last month. It is important to note that this is not the same as calling \code{first(X,'1 month')} or \code{first(X,'-1 month')}. All 4 variations return different subsets of data and have distinct purposes. If \code{n} is a character string, it must be of the form \sQuote{n period.type} or \sQuote{period.type}, where \code{n} is a numeric value (defaults to 1 if not provided) describing the number of \code{period.types} to move forward (first) or back (last). For example, to return the last 3 weeks of a time oriented zoo object, one could call \code{last(X,'3 weeks')}. Valid period.types are: secs, seconds, mins, minutes, hours, days, weeks, months, quarters, and years. It is possible to use any frequency specification (secs, mins, days, \ldots) for the period.type portion of the string, even if the original data is in a higher frequency. This makes it possible to return the last \sQuote{2 months} of data from an oject that has a daily periodicity. It should be noted that it is only possible to extract data with methods equal to or less than the frequency of the original data set. Attempting otherwise will result in error. Requesting more data than is in the original data object will produce a warning advising as such, and the object returned will simply be the original data. } \value{ A subset of elements/rows of the original data. } \author{ Jeffrey A. Ryan } \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') } \keyword{ utilities } xts/man/xts-internals.Rd0000644000176200001440000000516512473475737014777 0ustar liggesusers\name{xtsInternals} \alias{.dimnames.xts} \alias{dimnames.xts<-} \title{ Internal Documentation } \description{ 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 \code{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 \code{as.POSIXct}. There are defined types that meet this criteria. See \code{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 \R must be character vectors, and as such are inefficient in both storage and conversion. By eliminating the rownames, and providing a numeric index of \R internal type \code{REAL} or \code{INTEGER}, it is possible to maintain a connection to standard \R date and time classes via the POSIXct functions, while at at the same time maximizing efficiencies in data handling. User level functions \code{index}, as well as conversion to other classes proceeds as if there were rownames. The code for \code{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 \R. 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. } \author{ Jeffrey A. Ryan } \keyword{ utilities } xts/man/timeBased.Rd0000644000176200001440000000106112473475737014050 0ustar liggesusers\name{timeBased} \alias{timeBased} \alias{is.timeBased} \title{ Check if Class is Time-Based } \description{ Used to verify that the object is one of the known time-based classes in R. } \usage{ is.timeBased(x) timeBased(x) } \arguments{ \item{x}{ object to test } } \details{ Current time-based objects supported are \code{Date}, \code{POSIXct}, \code{chron}, \code{yearmon}, \code{yearqtr}, and \code{timeDate}. } \value{ Logical } \author{ Jeffrey A. Ryan } \examples{ timeBased(Sys.time()) timeBased(Sys.Date()) timeBased(200701) } \keyword{ utilities } xts/man/rbind.xts.Rd0000644000176200001440000000377212473475737014101 0ustar liggesusers\name{rbind.xts} \alias{rbind.xts} \alias{c.xts} \title{ Concatenate Two or More xts Objects by Row } \description{ Concatenate or bind by row two or more xts objects along a time-based index. } \usage{ \method{c}{xts}(...) \method{rbind}{xts}(..., deparse.level = 1) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{\dots}{ objects to bind } \item{deparse.level}{ not implemented } } \details{ Implemented in C, these functions bind \code{xts} objects by row, resulting in another \code{xts} object There may be non-unique index values in either the original series, or the resultant series. Identical indexed series are bound in the order or the arguments passed to rbind. See examples. All objects must have the same number of columns, as well as be \code{xts} objects or coercible to such. \code{rbind} and \code{c} are aliases. For traditional merge operations, see \code{merge.xts} and \code{cbind.xts}. } \value{ An \code{xts} object with one row per row for each object concatenated. } \author{ Jeffrey A. Ryan } \note{ This differs from rbind.zoo in that non-unique index values are allowed, in addition to the completely different algorithms used internally. All operations may not behave as expected on objects with non-unique indices. You have been warned. \code{rbind} is a .Primitive function in \R. As such method dispatch occurs at the C-level, and may not be consistent with expectations. See the details section of the base function, and if needed call rbind.xts directly to avoid dispatch ambiguity. } \seealso{ \code{\link{merge.xts}} \code{\link{rbind}} } \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) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ utilities } xts/man/period.sum.Rd0000644000176200001440000000222312473475737014241 0ustar liggesusers\name{period.sum} \alias{period.sum} \title{ Calculate Sum By Period } \description{ Calculate a sum for each period of INDEX. Essentially a rolling application of sum over a series of non-overlapping sections. } \usage{ period.sum(x, INDEX) } \arguments{ \item{x}{ a univariate data object } \item{INDEX}{ a numeric vector of endpoints to calculate sum on } } \details{ Used to calculate a sum per period given an arbitrary index of sections to be calculated over. This is an optimized function for sum. There are additionally optimized versions for min, max, and prod. For xts-coercible objects, an appropriate INDEX can be derived from a call to \code{endpoints}. } \value{ An \code{xts} or \code{zoo} object of sums, indexed by the period endpoints. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{endpoints}}, \code{\link{period.max}}, \code{\link{period.min}}, \code{\link{period.prod}} } \examples{ period.sum(c(1,1,4,2,2,6,7,8,-1,20),c(0,3,5,8,10)) data(sample_matrix) period.sum(sample_matrix[,1],endpoints(sample_matrix)) period.sum(as.xts(sample_matrix)[,1],endpoints(sample_matrix)) } \keyword{ utilities }% __ONLY ONE__ keyword per line xts/man/addLegend.Rd0000644000176200001440000000211013564762102014001 0ustar liggesusers\name{addLegend} \alias{addLegend} \title{Add Legend} \usage{ addLegend(legend.loc = "topright", legend.names = NULL, col = NULL, ncol = 1, on = 0, ...) } \arguments{ \item{legend.loc}{legend.loc places a legend into one of nine locations on the chart: bottomright, bottom, bottomleft, left, topleft, top, topright, right, or center.} \item{legend.names}{character vector of names for the legend. If \code{NULL}, the column names of the current plot object are used.} \item{col}{fill colors for the legend. If \code{NULL}, the colorset of the current plot object data is used.} \item{ncol}{number of columns for the legend} \item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}. The default, \code{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 \code{on} is checked for the default behavior to add to the last active panel.} \item{\dots}{any other passthrough parameters to \code{\link{legend}}.} } \description{ Add Legend } \author{ Ross Bennett } xts/man/xtsAPI.Rd0000644000176200001440000000267313564762102013320 0ustar liggesusers\name{xtsAPI} \alias{xtsAPI} \title{ xts C API Documentation } \description{ 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 \code{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: int 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) } } \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")) } } \author{ Jeffrey A. Ryan } \keyword{ utilities } xts/man/tzone.Rd0000644000176200001440000000562113564762102013303 0ustar liggesusers\name{indexTZ} \alias{TimeZone} \alias{indexTZ} \alias{indexTZ<-} \alias{tzone} \alias{tzone<-} \title{ Query the TimeZone of an xts object } \description{ Get the TimeZone of an \code{xts} object. } \usage{ indexTZ(x, ...) tzone(x, ...) indexTZ(x) <- value tzone(x) <- value } \arguments{ \item{x}{ an \code{xts} object } \item{value}{ a valid TZ object } \item{\dots}{ unused } } \details{ As of version 0.6-4 all objects carry the time zone under which they were created in a hidden attribute names \code{.indexTZ}. Going forward from 0.7-4, the TZ variable is now also stored in the index itself, in the \code{tzone} attribute. This is to facilitate the transition to removing the xts-specific attributes referenced by \code{tzone}, \code{indexFormat}, and \code{indexClass}. These accessor functions will continue to behave the same under the new internals. Additionally, there is a new getter/setter method with \code{tzone} and \code{tzone<-}. Internally, all time indexing is converted to POSIXct, seconds since the epoch as defined by a combination of the underlying OS and the TZ variable setting at creation. The current implementation of xts manages time zone information as transparently as possible, delegating all management to R, which is in turn managed in most instances by the underlying operating system. During printing, and subsetting by time strings the internal POSIX representation is used to identify in human-friendly terms the time at each position. This is different than previous versions of \pkg{xts}, where the index was stored in its native format (i.e. class). The ability to create an index using any of the supported timeBased classes (POSIXct, Date, dates, chron, timeDate, yearmon, yearqtr) is managed at the user-interaction point, and the class is merely stored in another index attribute, which is named \sQuote{tclass}. This is accessible and changeable via the \code{tclass} and \code{tclass(x)<-} functions. In most cases, all of this makes the subsetting by time strings possible, and also allows for consistent and fast manipulation of the series internally. Problems may arise when an object that had been created under one TZ (time zone) are used in a session using another TZ. This isn't usually a issue, but when it is a warning is given upon printing or subsetting. This warning may be controlled with \code{options("xts_check_TZ")}. } \value{ A named vector of length one, giving the objects TZ at creation. } \author{ Jeffrey A. Ryan } \note{ Timezones are a difficult issue to manage. If intraday granularity is not needed, it is often best to set the system TZ to "GMT" or "UTC". } \seealso{ \code{\link{POSIXt}} } \examples{ x <- xts(1:10, Sys.Date()+1:10) #indexTZ(x) # Deprecated(?) # same, preferred as of 0.9-1 tzone(x) str(x) x # now set TZ to something different... \dontrun{ Old.TZ <- Sys.getenv("TZ") Sys.setenv(TZ="America/Chicago") x Sys.setenv(TZ=Old.TZ) } } \keyword{ misc } xts/man/to.period.Rd0000644000176200001440000001221413564762102014043 0ustar liggesusers\name{to.period} \alias{to.period} \alias{to_period} \alias{to.minutes} \alias{to.minutes3} \alias{to.minutes5} \alias{to.minutes10} \alias{to.minutes15} \alias{to.minutes30} \alias{to.hourly} \alias{to.daily} \alias{to.weekly} \alias{to.monthly} \alias{to.quarterly} \alias{to.yearly} \alias{OHLC} \title{ Convert time series data to an OHLC series } \description{ 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. If volume for a period was available, the new volume will also be calculated. } \usage{ to.minutes(x,k,name,...) to.minutes3(x,name,...) to.minutes5(x,name,...) to.minutes10(x,name,...) to.minutes15(x,name,...) to.minutes30(x,name,...) to.hourly(x,name,...) to.daily(x,drop.time=TRUE,name,...) to.weekly(x,drop.time=TRUE,name,...) to.monthly(x,indexAt='yearmon',drop.time=TRUE,name,...) to.quarterly(x,indexAt='yearqtr',drop.time=TRUE,name,...) to.yearly(x,drop.time=TRUE,name,...) to.period(x, period = 'months', k = 1, indexAt, name=NULL, OHLC = TRUE, ...) } \arguments{ \item{x}{ a univariate or OHLC type time-series object } \item{period}{ period to convert to. See details. } \item{indexAt}{ convert final index to new class or date. See details } \item{drop.time}{ remove time component of POSIX datestamp (if any) } \item{k}{ number of sub periods to aggregate on (only for minutes and seconds) } \item{name}{ override column names } \item{OHLC}{ should an OHLC object be returned? (only \code{OHLC=TRUE} currently supported) } % \item{addlast}{ passed to \code{endpoints}. See also. } \item{\dots}{ additional arguments } } \details{ Essentially 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 \emph{end} of each period by default - with the exception of \code{to.monthly} and \code{to.quarterly}, which index by \sQuote{yearmon} and \sQuote{yearqtr} from the \pkg{zoo} package, respectively. Valid period character strings include: \code{"seconds"}, \code{"minutes"}, \code{"hours"}, \code{"days"}, \code{"weeks"}, \code{"months"}, \code{"quarters"}, and \code{"years"}. These are calculated internally via \code{endpoints}. See that function's help page for further details. To adjust the final indexing style, it is possible to set \code{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 \code{yearmon}, \code{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 \code{drop.time} to \code{TRUE} (the default) will convert a series that includes a time component into one with just a date index, as the time index is often of little value in lower frequency series. It is not possible to convert a series from a lower periodicity to a higher periodicity - e.g. weekly to daily or daily to 5 minute bars, as that would require magic. } \value{ 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 \code{aggregate} and \code{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 \code{as.xts} converts the original \code{x} into the universal \code{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 \code{NA} values. These are stripped for aggregation purposes, though replaced before returning. This inevitably leads to many, many additional \sQuote{NA} values in the data. It is more beneficial to consider using an \sQuote{xts} object originally, or converting to one in the function call by means of \code{as.xts}. } \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)) } \author{ Jeffrey A. Ryan } \keyword{ utilities } xts/man/endpoints.Rd0000644000176200001440000000267013564762102014150 0ustar liggesusers\name{endpoints} \alias{endpoints} \title{ Locate Endpoints by Time } \description{ Extract index values of a given \code{xts} object corresponding to the \emph{last} observations given a period specified by \code{on} } \usage{ endpoints(x, on="months", k=1) } \arguments{ \item{x}{ an xts object } \item{on}{ the periods endpoints to find as a character string } \item{k}{ along every k-th element - see notes } % \item{addlast}{ add last observation regardless of period endpoint } } \details{ \code{endpoints} returns a numeric vector corresponding to the \emph{last} observation in each period specified by \code{on}, with a zero added to the beginning of the vector, and the index of the last observation in \code{x} at the end. %The last observation may be left %off if it does not match a proper \sQuote{endpoint} and \code{addlast=FALSE}. Valid values for the argument \code{on} include: \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}. } \value{ A numeric vector of endpoints beginning with 0 and ending with the a value equal to the length of the x argument. } \author{ Jeffrey A. Ryan } \examples{ data(sample_matrix) endpoints(sample_matrix) endpoints(sample_matrix, 'weeks') } \keyword{ utilities } xts/man/period.min.Rd0000644000176200001440000000223212473475737014220 0ustar liggesusers\name{period.min} \alias{period.min} \title{ Calculate Min By Period } \description{ Calculate a minimum for each period of INDEX. Essentially a rolling application of minimum over a series of non-overlapping sections. } \usage{ period.min(x, INDEX) } \arguments{ \item{x}{ a univariate data object } \item{INDEX}{ a numeric vector of endpoints to calculate maximum on } } \details{ Used to calculate a minimum per period given an arbitrary index of sections to be calculated over. This is an optimized function for minimum. There are additional optimized versions for max, sum, and prod. For xts-coercible objects, an appropriate INDEX can be derived from a call to \code{endpoints}. } \value{ An xts or zoo object of minimums, indexed by the period endpoints. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{endpoints}}, \code{\link{period.sum}}, \code{\link{period.max}}, \code{\link{period.prod}} } \examples{ period.min(c(1,1,4,2,2,6,7,8,-1,20),c(0,3,5,8,10)) data(sample_matrix) period.min(sample_matrix[,1],endpoints(sample_matrix)) period.min(as.xts(sample_matrix)[,1],endpoints(sample_matrix)) } \keyword{ utilities }% __ONLY ONE__ keyword per line xts/man/xts.Rd0000644000176200001440000001250713607327605012766 0ustar liggesusers\name{xts} \alias{xts} \alias{is.xts} \title{ Create Or Test For An xts Time-Series Object } \description{ Constructor function for creating an extensible time-series object. \code{xts} is used to create an \code{xts} object from raw data inputs. } \usage{ xts(x = NULL, order.by = index(x), frequency = NULL, unique = TRUE, tzone = Sys.getenv("TZ"), ...) is.xts(x) } \arguments{ \item{x}{ an object containing the time series data } \item{order.by}{ a corresponding vector of unique times/dates - must be of a known time-based class. See details. } \item{frequency}{ numeric indicating frequency of \code{order.by}. See details. } \item{unique}{ should index be checked for unique time-stamps? } \item{tzone}{ time zone of series. This is ignored for Date indices } \item{\dots}{ additional attributes to be added. See details. } } \details{ An \code{xts} object extends the S3 class \code{zoo} from the package of the same name. 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 \code{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 \code{unique = FALSE} skips the uniqueness check and only ensures that the index is ordered via the \code{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 \code{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 \code{-Inf}, which will be first). Another difference is that the object may now 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. 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 \code{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, \sQuote{"["}, merge, cbind, rbind, c, Ops, lag, diff, coredata, head and tail. Additionally there are xts specific methods for converting amongst 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 with a double colon \dQuote{"::"} or \dQuote{"/"} operator. Each side of the operator may be left blank, which would then default to the beginning 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 \sQuote{left-filled}, that is to specify a full year one needs only to provide the year, a month would require 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 \code{xts} class to new classes to allow for method overloading. Additional benefits derive from the use of \code{as.xts} and \code{reclass}, which allow for lossless two-way conversion between common R time-series classes and the \code{xts} object structure. See those functions for more detail. } \value{ An S3 object of class \code{xts}. As it inherits and extends the zoo class, all zoo methods remain valid. Additional attributes may be assigned and extracted via \code{xtsAttributes}. } \references{ \pkg{zoo}: } \author{ Jeffrey A. Ryan and Joshua M. Ulrich } \note{ Most users will benefit the most by using the \code{as.xts} and \code{reclass} functions to automagically handle \emph{all} data objects as one would handle a \code{zoo} object. } \seealso{ \code{\link{as.xts}}, \code{\link{reclass}}, \code{\link{xtsAttributes}} } \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 } \keyword{ utilities } xts/man/periodicity.Rd0000644000176200001440000000320012473475737014474 0ustar liggesusers\name{periodicity} \alias{periodicity} \title{ Approximate Series Periodicity } \description{ Estimate the periodicity of a time-series-like object by calculating the median time between observations in days. } \usage{ periodicity(x, ...) } \arguments{ \item{x}{ time-series-like object } \item{\dots}{ unused } } \details{ A simple wrapper to quickly estimate the periodicity of a given data. Returning an object of type \code{periodicity}. This calculates the median number of days 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 \code{Date} or \code{POSIX} class, or coercible to such. The only list item of note is the \code{scale}. This is an estimate of the periodicity of the data in common terms - e.g. 7 day dialy data is best described as \sQuote{weekly}, and would be returned as such. Possible \code{scale} values are: \sQuote{minute},\sQuote{hourly}, \sQuote{daily},\sQuote{weekly}, \sQuote{monthly},\sQuote{quarterly}, and \sQuote{yearly}. } \value{ An object containing a list containing the \code{difftime} object, frequency, units, and suitable scale. } \note{ This function is only a \emph{good estimate} for the underlying periodicity. If the series is too short, or has \emph{no} real periodicity, the return values will obviously be wrong. That said, it is quite robust and used internally within \pkg{xts}. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{difftime}} } \examples{ zoo.ts <- zoo(rnorm(231),as.Date(13514:13744,origin="1970-01-01")) periodicity(zoo.ts) } \keyword{ utilities } xts/man/period.prod.Rd0000644000176200001440000000225312473475737014404 0ustar liggesusers\name{period.prod} \alias{period.prod} \title{ Calculate Product By Period } \description{ Calculate a product for each period of INDEX. Essentially a rolling application of prod over a series of non-overlapping sections. } \usage{ period.prod(x, INDEX) } \arguments{ \item{x}{ a univariate data object } \item{INDEX}{ a vector of breakpoints to calculate product on } } \details{ Used to calculate a product per period given an arbitrary index of sections to be calculated over. This is an optimized function for product. There are additionally optimized versions for min, max, and sum. For xts-coercible objects, an appropriate INDEX can be derived from a call to \code{endpoints}. } \value{ An \code{xts} or \code{zoo} object of products, indexed by the period endpoints. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{endpoints}}, \code{\link{period.sum}}, \code{\link{period.min}}, \code{\link{period.max}} } \examples{ period.prod(c(1,1,4,2,2,6,7,8,-1,20),c(0,3,5,8,10)) data(sample_matrix) period.prod(sample_matrix[,1],endpoints(sample_matrix)) period.prod(as.xts(sample_matrix)[,1],endpoints(sample_matrix)) } \keyword{ utilities }% __ONLY ONE__ keyword per line xts/man/apply.monthly.Rd0000644000176200001440000000276212530101636014754 0ustar liggesusers\name{apply.monthly} \alias{apply.daily} \alias{apply.weekly} \alias{apply.monthly} \alias{apply.quarterly} \alias{apply.yearly} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Apply Function over Calendar Periods } \description{ Apply a specified function to each distinct period in a given time series object. } \usage{ apply.daily(x, FUN, ...) apply.weekly(x, FUN, ...) apply.monthly(x, FUN, ...) apply.quarterly(x, FUN, ...) apply.yearly(x, FUN, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ an time-series object coercible to xts } \item{FUN}{ an \R function } \item{\dots}{ additional arguments to FUN } } \details{ 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 \code{endpoints} and \code{period.apply}, mainly as a convenience. } \value{ A vector of results produced by \code{FUN}, corresponding to the appropriate periods. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{endpoints}}, \code{\link{period.apply}}, \code{\link{to.monthly}} } \examples{ xts.ts <- xts(rnorm(231),as.Date(13514:13744,origin="1970-01-01")) start(xts.ts) end(xts.ts) apply.monthly(xts.ts,mean) apply.monthly(xts.ts,function(x) var(x)) } \keyword{ utilities } xts/man/addPanel.Rd0000644000176200001440000000325613564762102013656 0ustar liggesusers\name{addPanel} \alias{addPanel} \title{Add a panel to an existing xts plot} \usage{ addPanel(FUN, main = "", on = NA, type = "l", col = NULL, lty = 1, lwd = 1, pch = 1, ...) } \arguments{ \item{FUN}{an xts object to plot.} \item{main}{main title for a new panel if drawn.} \item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}.} \item{type}{the type of plot to be drawn, same as in \code{\link{plot}}.} \item{col}{color palette to use, set by default to rational choices.} \item{lty}{set the line type, same as in \code{\link{par}}.} \item{lwd}{set the line width, same as in \code{\link{par}}.} \item{pch}{the type of plot to be drawn, same as in \code{\link{par}}.} \item{\dots}{additional named arguments passed through to \code{FUN} and any other graphical passthrough parameters.} } \description{ Apply a function to the data of an existing xts plot object and plot the result. \code{FUN} should have arguments \code{x} or \code{R} for the data of the existing xts plot object to be passed to. All other additional arguments for \code{FUN} are passed through \dots. } \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) } xts/man/axTicksByTime.Rd0000644000176200001440000000321012473475737014671 0ustar liggesusers\name{axTicksByTime} \alias{axTicksByTime} \title{ Compute x-Axis Tickmark Locations by Time } \description{ Compute x-axis tickmarks like \code{axTicks} in base but with respect to time. Additionally the first argument is the object indexed by time which you are looking to derive tickmark locations for. It is possible to specify the detail you are seeking, or by passing 'auto' to the \code{ticks.on} argument, to get a best heuristic fit. } \usage{ axTicksByTime(x, ticks.on='auto', k = 1, labels=TRUE, format.labels=TRUE, ends=TRUE, gt = 2, lt = 30) } \arguments{ \item{x}{ the object indexed by time, or a vector of times/dates } \item{ticks.on}{ what to break on } \item{k}{ frequency of breaks } \item{labels}{ should a labeled vector be returned } \item{format.labels}{ format labels - may be format to use } \item{ends}{ should the ends be adjusted } \item{gt}{ lower bound on number of breaks } \item{lt}{ upper bound on number of breaks } } \details{ This function is written for internal use, and documented for those wishing to use outside of the internal function uses. In general it is most unlikely that the end user will call this function directly. The format.labels allows for standard formatting like that used in \code{format}, \code{strptime}, and \code{strftime}. } \value{ A vector of index points to break on, possibly with the index names. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{endpoints}} } \examples{ data(sample_matrix) axTicksByTime(as.xts(sample_matrix),'auto') axTicksByTime(as.xts(sample_matrix),'weeks') axTicksByTime(as.xts(sample_matrix),'months',7) } \keyword{ utilities } xts/man/tclass.Rd0000644000176200001440000000667513564762102013447 0ustar liggesusers\name{tclass} \alias{tclass} \alias{tformat} \alias{indexClass} \alias{indexFormat} \alias{convertIndex} \alias{indexClass<-} \alias{tclass<-} \alias{tformat<-} \alias{indexFormat<-} \alias{index.xts} \alias{index<-.xts} \alias{.indexhour} \alias{.indexsec} \alias{.indexmin} \alias{.indexyear} \alias{.indexymon} \alias{.indexyday} \alias{.indexday} \alias{.indexDate} \alias{.indexmday} \alias{.indexwday} \alias{.indexweek} \alias{.indexmon} \alias{.index} \alias{.index<-} \title{ Extracting/Replacing the Class of an xts Index } \description{ Generic functions to extract, replace, and format the class of the index of an xts object. } \usage{ \method{index}{xts}(x, ...) \method{index}{xts}(x) <- value .index(x, ...) .index(x) <- value indexClass(x) indexClass(x) <- value tclass(x, ...) tclass(x) <- value tformat(x) tformat(x) <- value convertIndex(x,value) # time component extraction/conversion .indexDate(x) .indexday(x) .indexmday(x) .indexwday(x) .indexweek(x) .indexmon(x) .indexyday(x) .indexyear(x) .indexhour(x) .indexmin(x) .indexsec(x) } \arguments{ \item{x}{ xts object } \item{value}{ desired new class or format. See details } \item{\dots}{ additional arguments (unused) } } \details{ The main accessor methods to an \code{xts} object's index is via the \code{index} and \code{index<-} replacement method. The structure of the index internally is now a numeric value corresponding to seconds since the epoch (POSIXct converted to numeric). This change allows for near native-speed matrix subsetting, as well as nearly instantaneous speed subsets by time. A call to \code{index} translates to the desired class on-the-fly. The desired index class is stored as an attribute within the xts object. Upon a standard \code{index} call, this is used to convert the numeric value to the desired class. It is possible to view and set the class of the time-index of a given \code{xts} object via the \code{tclass} function. To retrieve the raw numeric data a new accessor function (and replacement) has been added \code{.index}. This is primarily for internal use, but may be useful for end-users. \code{.indexXXX} functions are useful to extract time components of the underlying time index. The \sQuote{tclass} is virtual, and as such suitable conversions are made depending on the component requested. The specified value for \code{tclass<-} must be a character string containing one of the following: \code{Date}, \code{POSIXct}, \code{chron}, \code{yearmon}, \code{yearqtr} or \code{timeDate}. \code{tformat} only manages the manner in which the object is displayed via \code{print} (also called automatically when the object is returned) and in conversion to other classes such as \code{matrix}. The valid values for \code{tformat} are the same for \code{format.POSIXct}, as this is the function that does the conversion internally. \code{convertIndex} returns a modified \code{xts} object, and does \emph{not} alter the original. Changing the index type may alter the behavior of \pkg{xts} functions expecting a different index, as well as the functionality of additional methods. Use with caution. } \author{ Jeffrey A. Ryan } \examples{ x <- timeBasedSeq('2010-01-01/2010-01-02 12:00') x <- xts(1:length(x), x) # all obs. in the first 6 and last 3 minutes of the # 8th and 15th hours on each day x[.indexhour(x) \%in\% c(8,15) & .indexmin(x) \%in\% c(0:5,57:59)] # change the index format tformat(x) <- "\%Y-\%b-\%d \%H:\%M:\%OS3" head(x) } \keyword{ utilities } xts/man/as.xts.methods.Rd0000644000176200001440000000560213564762102015025 0ustar liggesusers\name{as.xts.methods} \alias{as.xts.methods} \alias{as.xts.timeSeries} \alias{as.timeSeries.xts} \alias{as.xts.xts} \alias{as.xts.zoo} \alias{as.xts.ts} \alias{as.xts.fts} \alias{as.xts.data.frame} \alias{as.xts.matrix} \alias{as.fts.xts} \title{ Convert Object To And From Class xts } \description{ Conversion S3 methods to coerce data objects of arbitrary classes to class \code{xts} and back, without losing any attributes of the original format. } \usage{ \method{as.xts}{xts}(x,...,.RECLASS=FALSE) \method{as.xts}{timeSeries}(x, dateFormat="POSIXct", FinCenter, recordIDs, title, documentation, ..., .RECLASS=FALSE) \method{as.xts}{zoo}(x, order.by=index(x), frequency=NULL, ..., .RECLASS=FALSE) \method{as.xts}{ts}(x, dateFormat,...,.RECLASS=FALSE) \method{as.xts}{data.frame}(x, order.by, dateFormat="POSIXct", frequency=NULL, ...,.RECLASS=FALSE) \method{as.xts}{matrix}(x, order.by, dateFormat="POSIXct", frequency=NULL, ..., .RECLASS=FALSE) as.fts.xts(x) } \arguments{ \item{x}{ data object to convert. See details for supported types } \item{dateFormat}{what format should the dates be converted to} \item{FinCenter}{see timeSeries help} \item{recordIDs}{see timeSeries help} \item{title}{see timeSeries help} \item{documentation}{see timeSeries help} \item{order.by}{see zoo help} \item{frequency}{see zoo help} \item{\dots}{ additional parameters or attributes } \item{.RECLASS}{ should conversion be reversible? } } \details{ A simple and reliable way to convert many different objects into a uniform format for use within \R. It is possible with a call to \code{as.xts} to convert objects of class \code{timeSeries}, \code{ts}, \code{matrix}, \code{data.frame}, and \code{zoo}. Additional name=value pairs may be passed to the function to be added to the new object. A special print.xts method will assure that the attributes are hidden from view, but will be available via \R's standard \code{attr} function. If .RECLASS=TRUE, the returned object will preserve all relevant attribute/slot data within itself, allowing for temporary conversion to use zoo and xts compatible methods. A call to \code{reclass} returns the object to its original class, with all original attributes intact - unless otherwise changed. This is the default behavior when \code{try.xts} is used for conversion, and should not be altered by the user; i.e. don't touch it unless you are aware of the consequences. It should be obvious, but any attributes added via the \dots argument will not be carried back to the original data object, as there would be no available storage slot/attribute. } \value{ An S3 object of class \code{xts}. } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{xts}} } \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)) ) } } \keyword{ utilities } xts/man/dimnames.xts.Rd0000644000176200001440000000421412473475737014570 0ustar liggesusers\name{dimnames.xts} \alias{dimnames.xts} \alias{dimnames<-.xts} \title{ Dimnames of an xts Object } \description{ Get or set dimnames of an xts object. } \usage{ \method{dimnames}{xts}(x) \method{dimnames}{xts}(x) <- value } \arguments{ \item{x}{ an xts object } \item{value}{ a list object of length two. See Details. } } \details{ The functions \code{dimnames.xts} and \code{dimnames<-.xts} are methods for the base functions \code{dimnames} and \code{dimnames<-}. \code{xts} objects by design are intended for lightweight management of time-indexed data. Rownames are redundant in this design, as well as quite burdensome with respect to memory consumption and internal copying costs. \code{rownames} and \code{colnames} in \R make use of \code{dimnames} method dispatch internally, and thus require only modifications to dimnames to enforce the \code{xts} no rownames requirement. To prevent accidental setting of rownames, \code{dimnames<-} for \code{xts} will simply set the rownames to \code{NULL} when invoked, regardless of attempts to set otherwise. This is done for internal compatibility reasons, as well as to provide consistency in performance regardless of object use. User level interaction with either dimnames or rownames will produce a character vector of the index, formatted based on the current specification of \code{indexFormat}. This occurs within the call by converting the results of calling \code{index(x)} to a character string, which itself first creates the object type specified internally from the underlying numeric time representation. } \value{ 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. This is your warning. } \author{ Jeffrey A. Ryan } \note{ All \code{xts} objects have dimension. There are no \code{xts} objects representable as named or unnamed vectors. } \seealso{ \code{\link{xts}} } \examples{ x <- xts(1:10, Sys.Date()+1:10) dimnames(x) rownames(x) rownames(x) <- 1:10 rownames(x) str(x) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ misc } xts/man/sample.data.Rd0000644000176200001440000000077312473475737014355 0ustar liggesusers\name{sample_matrix} \alias{sample_matrix} \docType{data} \title{ Sample Data Matrix For xts Example and Unit Testing } \description{ 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" } } \examples{ data(.sample.matrix) } \keyword{datasets} xts/man/addPolygon.Rd0000644000176200001440000000202213564762102014234 0ustar liggesusers\name{addPolygon} \alias{addPolygon} \title{Add a polygon to an existing xts plot} \description{ 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. } \usage{ addPolygon(x, y = NULL, main = "", on = NA, col = NULL, ...) } \arguments{ \item{x}{ an xts object to plot. Must contain 2 columns for the upper and lower y coordinates for the polygon. The first column is interpreted as the upper y coordinates and the second column as the lower y coordinates. } \item{y}{NULL, not used} \item{main}{main title for a new panel if drawn.} \item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}.} \item{col}{color palette to use, set by default to rational choices.} \item{\dots}{passthru parameters to \code{\link{par}}} } \references{ Based on code by Dirk Eddelbuettel from \url{http://dirk.eddelbuettel.com/blog/2011/01/16/} } \author{Ross Bennett} xts/man/na.locf.xts.Rd0000644000176200001440000000276212530101636014273 0ustar liggesusers\name{na.locf.xts} \alias{na.locf.xts} %- Also NEED an '\alias' for EACH other topic documented here. \title{ Last Observation Carried Forward } \description{ \pkg{xts} method replace \sQuote{NA} with most recent non-\sQuote{NA} } \usage{ \method{na.locf}{xts}(object, na.rm = FALSE, fromLast = FALSE, maxgap=Inf, ...) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{object}{ an xts object } \item{na.rm}{ logical. Should leading/trailing \sQuote{NA}'s be removed? The default for xts \code{FALSE} is different than the default S3 method in the \pkg{zoo} package. } \item{fromLast}{ logical. Cause observations to be carried backward rather than forward. Default is \code{FALSE}. } \item{maxgap}{ runs of more than \sQuote{maxgap} will retain \sQuote{NA}s after the maximum gap specified. See \code{na.locf} in the zoo package. } \item{\dots}{ unused } } \details{ This is the \pkg{xts} method for the S3 generic \code{na.locf}. The primary difference to note is that after the \sQuote{NA} fill action is carried out, the default it to leave trailing or leading \sQuote{NA}'s in place. This is different than \pkg{zoo} behavior. } \value{ See the documentation in zoo. } \references{ \sQuote{zoo} } \author{ Jeffrey A. Ryan } \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) } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ misc } xts/man/addSeries.Rd0000644000176200001440000000152213564762102014043 0ustar liggesusers\name{addSeries} \alias{addSeries} \title{Add a time series to an existing xts plot} \usage{ addSeries(x, main = "", on = NA, type = "l", col = NULL, lty = 1, lwd = 1, pch = 1, ...) } \arguments{ \item{x}{an xts object to plot.} \item{main}{main title for a new panel if drawn.} \item{on}{panel number to draw on. A new panel will be drawn if \code{on=NA}.} \item{type}{the type of plot to be drawn, same as in \code{\link{plot}}.} \item{col}{color palette to use, set by default to rational choices.} \item{lty}{set the line type, same as in \code{\link{par}}.} \item{lwd}{set the line width, same as in \code{\link{par}}.} \item{pch}{the type of plot to be drawn, same as in \code{\link{par}}.} \item{\dots}{any other passthrough graphical parameters.} } \description{ Add a time series to an existing xts plot } \author{ Ross Bennett } xts/man/as.environment.Rd0000644000176200001440000000210713457105664015113 0ustar liggesusers\name{as.environment.xts} \alias{as.environment.xts} \title{ Coerce an \sQuote{xts} Object to an Environment by Column } \description{ Method to automatically convert an \sQuote{xts} object to an environment containing vectors representing each column of the original xts object. Each objects will be named according to the column name it is exracted by. } \usage{ \method{as.environment}{xts}(x) } \arguments{ \item{x}{ an \code{xts} object } } \details{ An experimental tool to convert \code{xts} objects into environments for simplifying use withing the standard R formula/data paradigm. } \value{ An \code{environment} containing \code{ncol(x)} vectors extracted by column from \code{x}. Note that environments do not preserve (or have knowledge) of column position, a.k.a order. } \author{ Jeffrey A. Ryan } \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) } \keyword{ manip }% __ONLY ONE__ keyword per line xts/man/period.apply.Rd0000644000176200001440000000262712530101636014544 0ustar liggesusers\name{period.apply} \alias{period.apply} \title{ Apply Function Over Specified Interval } \description{ Apply a specified function to data over a given interval, where the interval is taken to be the data from INDEX[k] to INDEX[k+1], for k=1:(length(INDEX)-1). } \usage{ period.apply(x, INDEX, FUN, ...) } \arguments{ \item{x}{ data to apply FUN to } \item{INDEX}{ numeric vector specifying indexing } \item{FUN}{ an argument of type \code{function} } \item{\dots}{ additional arguments for \code{FUN}} } \details{ Similar to the rest of the apply family, calculate a specified functions value given a shifting set of data values. The primary difference is that it is that \code{period.apply} applies a function to non-overlapping intervals along a vector. Useful for applying arbitrary functions over an entire data object by an aribirtary index, as when INDEX is the result of a call to breakpoints. } \value{ A vector with length of INDEX minus 1 } \author{ Jeffrey A. Ryan } \seealso{ \code{\link{endpoints}} \code{\link{apply.monthly}}} \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) mean(x)) period.apply(zoo.data, INDEX=ep, FUN=mean) #same glue <- function(x) { paste(x,collapse='') } period.apply(letters,c(0,5,7,26),glue) } \keyword{ utilities }% __ONLY ONE__ keyword per line xts/DESCRIPTION0000644000176200001440000000221313611112162012566 0ustar liggesusersPackage: xts Type: Package Title: eXtensible Time Series Version: 0.12-0 Authors@R: c( person(given=c("Jeffrey","A."), family="Ryan", role=c("aut","cph")), person(given=c("Joshua","M."), family="Ulrich", role=c("cre","aut"), email="josh.m.ulrich@gmail.com"), person(given="Ross", family="Bennett", role="ctb"), person(given="Corwin", family="Joy", role="ctb") ) Depends: zoo (>= 1.7-12) Imports: methods LinkingTo: zoo Suggests: timeSeries, timeDate, tseries, chron, fts, tis, RUnit LazyLoad: yes Description: Provide for uniform handling of R's different time-based data classes by extending zoo, maximizing native format information preservation and allowing for user level customization and extension, while simplifying cross-class interoperability. License: GPL (>= 2) URL: https://github.com/joshuaulrich/xts BugReports: https://github.com/joshuaulrich/xts/issues NeedsCompilation: yes Packaged: 2020-01-14 12:31:51 UTC; josh Author: Jeffrey A. Ryan [aut, cph], Joshua M. Ulrich [cre, aut], Ross Bennett [ctb], Corwin Joy [ctb] Maintainer: Joshua M. Ulrich Repository: CRAN Date/Publication: 2020-01-19 17:40:02 UTC xts/build/0000755000176200001440000000000013607332267012200 5ustar liggesusersxts/build/vignette.rds0000644000176200001440000000035313607332267014540 0ustar liggesusersu@EA0&&6|*lWMx(KZ※&;3=9PS#:őN&n 6xts/tests/0000755000176200001440000000000013564762102012240 5ustar liggesusersxts/tests/doRUnit.R0000644000176200001440000000424013564762102013747 0ustar liggesusers## unit tests will not be done if RUnit is not available if(require("RUnit", quietly=TRUE)) { ## --- Setup --- R_CMD_CHECK <- Sys.getenv("RCMDCHECK") != "FALSE" pkg <- "xts" # <-- Change to package name! if (R_CMD_CHECK) { ## Path to unit tests for R CMD check ## PKG.Rcheck/tests/../PKG/unitTests path <- system.file(package=pkg, "unitTests") } else { ## Path to unit tests for standalone running under Makefile (not R CMD check) ## PKG/tests/../inst/unitTests path <- file.path(getwd(), "..", "inst", "unitTests") } cat("\nRunning unit tests\n") print(list(pkg=pkg, getwd=getwd(), pathToUnitTests=path)) library(package=pkg, character.only=TRUE) ## If desired, load the name space to allow testing of private functions ## if (is.element(pkg, loadedNamespaces())) ## attach(loadNamespace(pkg), name=paste("namespace", pkg, sep=":"), pos=3) ## ## or simply call PKG:::myPrivateFunction() in tests ## --- Testing --- ## Define tests testSuite <- defineTestSuite(name=paste(pkg, "unit testing"), dirs=path) ## Run tests <- runTestSuite(testSuite) ## Report to stdout cat("------------------- UNIT TEST SUMMARY ---------------------\n\n") printTextProtocol(tests, showDetails=FALSE) ## Report text files (only if not under R CMD check) if (!R_CMD_CHECK) { ## Default report name pathReport <- file.path(path, "report") printTextProtocol(tests, showDetails=FALSE, fileName=paste(pathReport, "Summary.txt", sep="")) printTextProtocol(tests, showDetails=TRUE, fileName=paste(pathReport, ".txt", sep="")) ## Report to HTML file printHTMLProtocol(tests, fileName=paste(pathReport, ".html", sep="")) } ## Return stop() to cause R CMD check stop in case of ## - failures i.e. FALSE to unit tests or ## - errors i.e. R errors tmp <- getErrors(tests) if(tmp$nFail > 0 | tmp$nErr > 0) { stop(paste("\n\nunit testing failed (#test failures: ", tmp$nFail, ", #R errors: ", tmp$nErr, ")\n\n", sep="")) } } else { warning("cannot run unit tests -- package RUnit is not available") } xts/src/0000755000176200001440000000000013607332267011670 5ustar liggesusersxts/src/isOrdered.c0000644000176200001440000000757413564762102013766 0ustar liggesusers/* # 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 . */ #include #include #include SEXP do_is_ordered (SEXP x, SEXP increasing, SEXP strictly) { int i; int nx = LENGTH(x) - 1; double *real_x; int *int_x; /* If length is 0 then it is ordered */ if (nx < 0) return ScalarLogical(1); if(TYPEOF(x) == REALSXP) { /* Check for increasing order, strict or non-strict */ real_x = REAL(x); if(LOGICAL(increasing)[ 0 ] == 1) { /* INCREASING */ if(LOGICAL(strictly)[ 0 ] == 1) { /* STRICTLY INCREASING ( > 0 ) */ for(i = 0; i < nx; i++) { if( real_x[i+1] <= real_x[i] ) { return ScalarLogical(0); } } } else { /* NOT-STRICTLY ( 0 || > 0 ) */ for(i = 0; i < nx; i++) { if( real_x[i+1] < real_x[i] ) { return ScalarLogical(0); } } } /* Check for decreasing order, strict or non-strict */ } else { if(LOGICAL(strictly)[ 0 ] == 1) { /* STRICTLY DECREASING ( < 0 ) */ for(i = 0; i < nx; i++) { if( real_x[i+1] >= real_x[i] ) { return ScalarLogical(0); } } } else { /* NOT-STRICTLY ( 0 || < 0 ) */ for(i = 0; i < nx; i++) { if( real_x[i+1] > real_x[i] ) { return ScalarLogical(0); } } } } } else if(TYPEOF(x) == INTSXP) { /* Check for increasing order, strict or non-strict */ int_x = INTEGER(x); if(LOGICAL(increasing)[ 0 ] == 1) { /* INCREASING */ /* Not increasing order if first element is NA. We know x has at least 1 element. */ if( int_x[0] == NA_INTEGER ) return ScalarLogical(0); if(LOGICAL(strictly)[ 0 ] == 1) { /* STRICTLY INCREASING ( > 0 ) */ for(i = 0; i < nx; i++) { if( int_x[i+1] <= int_x[i] ) { if (i == (nx-1) && int_x[i+1] == NA_INTEGER) { continue; /* OK if NA is last element */ } return ScalarLogical(0); } } } else { /* NOT-STRICTLY ( 0 || > 0 ) */ for(i = 0; i < nx; i++) { if( int_x[i+1] < int_x[i] ) { if (i == (nx-1) && int_x[i+1] == NA_INTEGER) { continue; /* OK if NA is last element */ } return ScalarLogical(0); } } } /* Check for decreasing order, strict or non-strict */ } else { /* DECREASING */ /* Not decreasing order if last element is NA */ if( int_x[nx] == NA_INTEGER ) return ScalarLogical(0); if(LOGICAL(strictly)[ 0 ] == 1) { /* STRICTLY DECREASING ( < 0 ) */ for(i = 0; i < nx; i++) { if( int_x[i+1] >= int_x[i] ) { if (i == 0 && int_x[i] == NA_INTEGER) { continue; /* OK if NA is first element */ } return ScalarLogical(0); } } } else { /* NOT-STRICTLY ( 0 || < 0 ) */ for(i = 0; i < nx; i++) { if( int_x[i+1] > int_x[i] ) { if (i == 0 && int_x[i] == NA_INTEGER) { continue; /* OK if NA is first element */ } return ScalarLogical(0); } } } } } else { error("'x' must be of type double or integer"); } return ScalarLogical(1); /* default to true */ } xts/src/period_arithmetic.c0000644000176200001440000000427513564762102015534 0ustar liggesusers/* # xts: eXtensible time-series # # Copyright (C) 2008 Jeffrey A. Ryan (FORTRAN implementation) # Copyright (C) 2018 Joshua M. Ulrich (C implementation) # # 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 . */ #include SEXP xts_period_prod(SEXP _data, SEXP _index) { if (ncols(_data) > 1) { error("single column data only"); } if (!isInteger(_index)) { error("index must be integer"); } if (!isReal(_data)) { error("data must be double"); } int i, j; int n = length(_index) - 1; SEXP _result = PROTECT(allocVector(REALSXP, n)); double *result = REAL(_result); int *index = INTEGER(_index); double *data = REAL(_data); int k = 0; for (i = 0; i < n; i++) { int idx0 = index[i]; int idx1 = index[i + 1]; double prod = data[idx0]; for (j = idx0+1; j < idx1; j++) { prod *= data[j]; } result[k++] = prod; } UNPROTECT(1); return _result; } SEXP xts_period_sum(SEXP _data, SEXP _index) { if (ncols(_data) > 1) { error("single column data only"); } if (!isInteger(_index)) { error("index must be integer"); } if (!isReal(_data)) { error("data must be double"); } int i, j; int n = length(_index) - 1; SEXP _result = PROTECT(allocVector(REALSXP, n)); double *result = REAL(_result); int *index = INTEGER(_index); double *data = REAL(_data); int k = 0; for (i = 0; i < n; i++) { int idx0 = index[i]; int idx1 = index[i + 1]; double sum = data[idx0]; for (j = idx0+1; j < idx1; j++) { sum += data[j]; } result[k++] = sum; } UNPROTECT(1); return _result; } xts/src/subset.old.c0000644000176200001440000002171613564762102014122 0ustar liggesusers/* # 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 . */ /* Base code borrowed from R's main/src/subset.c to see how to create a function to subset an xts object in it's entirety All modification are by Jeffrey A. Ryan 2008 */ #include #include #include #include "xts.h" // xtsExtractSubset {{{ static SEXP xtsExtractSubset(SEXP x, SEXP result, SEXP indx) //, SEXP call) { int i, ii, n, nx, mode; SEXP tmp, tmp2; mode = TYPEOF(x); n = LENGTH(indx); nx = length(x); tmp = result; if (x == R_NilValue) return x; for (i = 0; i < n; i++) { ii = INTEGER(indx)[i]; if (ii != NA_INTEGER) ii--; switch (mode) { case LGLSXP: if (0 <= ii && ii < nx && ii != NA_LOGICAL) LOGICAL(result)[i] = LOGICAL(x)[ii]; else LOGICAL(result)[i] = NA_LOGICAL; break; case INTSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) INTEGER(result)[i] = INTEGER(x)[ii]; else INTEGER(result)[i] = NA_INTEGER; break; case REALSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) REAL(result)[i] = REAL(x)[ii]; else REAL(result)[i] = NA_REAL; break; case CPLXSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) { COMPLEX(result)[i] = COMPLEX(x)[ii]; } else { COMPLEX(result)[i].r = NA_REAL; COMPLEX(result)[i].i = NA_REAL; } break; case STRSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) SET_STRING_ELT(result, i, STRING_ELT(x, ii)); else SET_STRING_ELT(result, i, NA_STRING); break; case VECSXP: case EXPRSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii)); else SET_VECTOR_ELT(result, i, R_NilValue); break; case LISTSXP: /* cannot happen: pairlists are coerced to lists */ case LANGSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) { tmp2 = nthcdr(x, ii); SETCAR(tmp, CAR(tmp2)); SET_TAG(tmp, TAG(tmp2)); } else SETCAR(tmp, R_NilValue); tmp = CDR(tmp); break; case RAWSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) RAW(result)[i] = RAW(x)[ii]; else RAW(result)[i] = (Rbyte) 0; break; default: error("error in subset\n"); // errorcall(call, R_MSG_ob_nonsub, type2char(mode)); break; } } return result; } //}}} SEXP do_subset_xts(SEXP x, SEXP sr, SEXP sc, SEXP drop) //SEXP s, SEXP call, int drop) { SEXP attr, result, dim; int nr, nc, nrs, ncs; int i, j, ii, jj, ij, iijj; int mode; int *int_x=NULL, *int_result=NULL, *int_newindex=NULL, *int_index=NULL; double *real_x=NULL, *real_result=NULL, *real_newindex=NULL, *real_index=NULL; nr = nrows(x); nc = ncols(x); if( length(x)==0 ) return x; dim = getAttrib(x, R_DimSymbol); nrs = LENGTH(sr); ncs = LENGTH(sc); int *int_sr=NULL, *int_sc=NULL; int_sr = INTEGER(sr); int_sc = INTEGER(sc); mode = TYPEOF(x); result = allocVector(mode, nrs*ncs); PROTECT(result); if( mode==INTSXP ) { int_x = INTEGER(x); int_result = INTEGER(result); } else if( mode==REALSXP ) { real_x = REAL(x); real_result = REAL(result); } /* code to handle index of xts object efficiently */ SEXP index, newindex; int indx; index = getAttrib(x, xts_IndexSymbol); PROTECT(index); if(TYPEOF(index) == INTSXP) { newindex = allocVector(INTSXP, LENGTH(sr)); PROTECT(newindex); int_newindex = INTEGER(newindex); int_index = INTEGER(index); for(indx = 0; indx < nrs; indx++) { int_newindex[indx] = int_index[ (int_sr[indx])-1]; } copyAttributes(index, newindex); setAttrib(result, xts_IndexSymbol, newindex); UNPROTECT(1); } if(TYPEOF(index) == REALSXP) { newindex = allocVector(REALSXP, LENGTH(sr)); PROTECT(newindex); real_newindex = REAL(newindex); real_index = REAL(index); for(indx = 0; indx < nrs; indx++) { real_newindex[indx] = real_index[ (int_sr[indx])-1 ]; } copyAttributes(index, newindex); setAttrib(result, xts_IndexSymbol, newindex); UNPROTECT(1); } for (i = 0; i < nrs; i++) { ii = int_sr[i]; if (ii != NA_INTEGER) { if (ii < 1 || ii > nr) error("i is out of range\n"); ii--; } /* Begin column loop */ for (j = 0; j < ncs; j++) { //jj = INTEGER(sc)[j]; jj = int_sc[j]; if (jj != NA_INTEGER) { if (jj < 1 || jj > nc) error("j is out of range\n"); jj--; } ij = i + j * nrs; if (ii == NA_INTEGER || jj == NA_INTEGER) { switch ( mode ) { case REALSXP: real_result[ij] = NA_REAL; break; case LGLSXP: case INTSXP: int_result[ij] = NA_INTEGER; break; case CPLXSXP: COMPLEX(result)[ij].r = NA_REAL; COMPLEX(result)[ij].i = NA_REAL; break; case STRSXP: SET_STRING_ELT(result, ij, NA_STRING); break; case VECSXP: SET_VECTOR_ELT(result, ij, R_NilValue); break; case RAWSXP: RAW(result)[ij] = (Rbyte) 0; break; default: error("xts subscripting not handled for this type"); break; } } else { iijj = ii + jj * nr; switch ( mode ) { case REALSXP: real_result[ij] = real_x[iijj]; break; case LGLSXP: LOGICAL(result)[ij] = LOGICAL(x)[iijj]; break; case INTSXP: int_result[ij] = int_x[iijj]; break; case CPLXSXP: COMPLEX(result)[ij] = COMPLEX(x)[iijj]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(x, iijj)); break; case VECSXP: SET_VECTOR_ELT(result, ij, VECTOR_ELT(x, iijj)); break; case RAWSXP: RAW(result)[ij] = RAW(x)[iijj]; break; default: error("matrix subscripting not handled for this type"); break; } } } /* end of column loop */ } /* end of row loop */ if(nrs >= 0 && ncs >= 0 && !isNull(dim)) { PROTECT(attr = allocVector(INTSXP, 2)); INTEGER(attr)[0] = nrs; INTEGER(attr)[1] = ncs; setAttrib(result, R_DimSymbol, attr); UNPROTECT(1); } /* The matrix elements have been transferred. Now we need to */ /* transfer the attributes. Most importantly, we need to subset */ /* the dimnames of the returned value. */ if (nrs >= 0 && ncs >= 0 && !isNull(dim)) { SEXP dimnames, dimnamesnames, newdimnames; dimnames = getAttrib(x, R_DimNamesSymbol); dimnamesnames = getAttrib(dimnames, R_NamesSymbol); if (!isNull(dimnames)) { PROTECT(newdimnames = allocVector(VECSXP, 2)); if (TYPEOF(dimnames) == VECSXP) { SET_VECTOR_ELT(newdimnames, 0, xtsExtractSubset(VECTOR_ELT(dimnames, 0), allocVector(STRSXP, nrs), sr)); SET_VECTOR_ELT(newdimnames, 1, xtsExtractSubset(VECTOR_ELT(dimnames, 1), allocVector(STRSXP, ncs), sc)); } else { SET_VECTOR_ELT(newdimnames, 0, xtsExtractSubset(CAR(dimnames), allocVector(STRSXP, nrs), sr)); SET_VECTOR_ELT(newdimnames, 1, xtsExtractSubset(CADR(dimnames), allocVector(STRSXP, ncs), sc)); } setAttrib(newdimnames, R_NamesSymbol, dimnamesnames); setAttrib(result, R_DimNamesSymbol, newdimnames); UNPROTECT(1); } } copyAttributes(x, result); if(ncs == 1 && LOGICAL(drop)[0]) setAttrib(result, R_DimSymbol, R_NilValue); UNPROTECT(2); return result; } xts/src/unique.time.c0000644000176200001440000000747513564762102014311 0ustar liggesusers/* # 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 . */ #include #include "xts.h" /* for coredata_xts */ SEXP make_unique (SEXP index_, SEXP eps_) { int P = 0, i; int len = length(index_); double eps = asReal(eps_); if (TYPEOF(index_) == INTSXP) { PROTECT(index_ = coerceVector(index_, REALSXP)); P++; } SEXP newindex_ = PROTECT(allocVector(REALSXP, len)); P++; copyAttributes(index_, newindex_); double *newindex_real = REAL(newindex_); memcpy(REAL(newindex_), REAL(index_), len * sizeof(double)); double last_index = newindex_real[0]; int warn_once = 1; for(i=1; i. */ #include #include #include #include "xts.h" int isXts(SEXP x) { int i; SEXP attr, index; index = getAttrib(x, xts_IndexSymbol); PROTECT( attr = coerceVector(getAttrib(x, R_ClassSymbol),STRSXP) ); if(length(attr) <= 1) { UNPROTECT(1); return 0; } for(i = 0; i < length(attr); i++) { if(STRING_ELT(attr, i) == mkChar("xts")) { /* check for index attribute */ if(TYPEOF(index)==REALSXP || TYPEOF(index)==INTSXP) { UNPROTECT(1); return 1; } else { UNPROTECT(1); return 0; } } } UNPROTECT(1); return FALSE; } /* test function and example */ SEXP test_isXts(SEXP x) { if(isXts(x)) { Rprintf("TRUE\n"); } else { Rprintf("FALSE\n"); } return R_NilValue; } xts/src/toperiod.c0000644000176200001440000002026513564762102013663 0ustar liggesusers/* # 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 . */ /* Possible solution to allow for a generalized single function might be to pass in a vector of available 'actions': {0=first, 1=max, 2=min, 3=last, 4=sum} This would lead to OHLC to have: 0,1,2,3 [,4[,3]] The current algorithm is in 3 stages per endpoint interation: Stage 1: Calculate first (0) of each column, this is the Op and set Hi and Lo to this value Stage 2: Cycle through all x[j] where j is ep[i]:ep[i+1] and i is 1:NROW(ep) Keep running min, max, and summation (Lo, Hi, "Volume") Stage 3: Get last value for close. Repeat for next endpoint */ #include #include /*#include */ #include "xts.h" #ifndef MAX #define MAX(a,b) (a > b ? a : b) #endif #ifndef MIN #define MIN(a,b) (a < b ? a : b) #endif SEXP toPeriod(SEXP x, SEXP endpoints, SEXP hasVolume, SEXP whichVolume, SEXP hasAdjusted, SEXP first, SEXP colnames) { SEXP result, ohlc, xindex, newindex, dimnames; int i, j=0, nrx, ncx, ncr, n, P=0; nrx = nrows(x); ncx = ncols(x); n = nrows(endpoints) - 1; ncr = 4; /* OHLC */ int mode = TYPEOF(x); int Hi, Lo, Cl, Vo; if(ncx >= 4) { /* needs OHLC or bust, clearly not the best solution since we can't just skip over columns */ Hi=1; Lo=2; Cl=3; } else { Hi=Lo=Cl=0; } if(INTEGER(hasVolume)[0]) ncr++; /* Volume */ if(INTEGER(hasAdjusted)[0]) ncr++; /* Adjusted (Yahoo) */ /* handle index values in xts */ PROTECT(xindex = getAttrib(x, xts_IndexSymbol)); P++; int index_mode = TYPEOF(xindex); PROTECT(newindex = allocVector(index_mode, n)); P++; PROTECT(result = allocVector(mode, n * ncr )); P++; PROTECT(ohlc = allocVector(mode, 6)); P++; int _FIRST = (INTEGER(first)[0]); int *ohlc_int = NULL, *result_int = NULL, *x_int = NULL; double *ohlc_real = NULL, *result_real = NULL, *x_real = NULL; switch(mode) { case INTSXP: ohlc_int = INTEGER(ohlc); result_int = INTEGER(result); x_int = INTEGER(x); break; case REALSXP: ohlc_real = REAL(ohlc); result_real = REAL(result); x_real = REAL(x); break; default: error("unsupported type"); } int *_endpoints = INTEGER(endpoints); int _hasAdjusted = INTEGER(hasAdjusted)[0]; int _hasVolume = INTEGER(hasVolume)[0]; /* volume column number */ Vo = _hasVolume ? asInteger(whichVolume)-1 : 0; for(i = 0; i < n; i++) { j = _endpoints[i]; if(_FIRST) { switch(index_mode) { case INTSXP: INTEGER(newindex)[i] = INTEGER(xindex)[j]; break; case REALSXP: REAL(newindex)[i] = REAL(xindex)[j]; break; } } /* set the Open, and initialize High, Low and Volume */ switch(mode) { case INTSXP: ohlc_int[0] = x_int[j]; /* Op */ ohlc_int[1] = x_int[j + Hi*nrx]; /* Hi */ ohlc_int[2] = x_int[j + Lo*nrx]; /* Lo */ if(_hasVolume) ohlc_int[4] = (int)0; /* Vo */ break; case REALSXP: ohlc_real[0] = x_real[j]; /* Op */ ohlc_real[1] = x_real[j + Hi*nrx]; /* Hi */ ohlc_real[2] = x_real[j + Lo*nrx]; /* Lo */ if(_hasVolume) ohlc_real[4] = (double)0; /* Vo */ break; } // set the High, Low, and Volume switch(mode) { case INTSXP: for( ; j < _endpoints[i+1]; j++) { ohlc_int[1] = MAX(ohlc_int[1], x_int[j + Hi*nrx]); /* HI */ ohlc_int[2] = MIN(ohlc_int[2], x_int[j + Lo*nrx]); /* LO */ if(_hasVolume) ohlc_int[4] = ohlc_int[4] + x_int[j + Vo*nrx]; /* VO */ } break; case REALSXP: for( ; j < _endpoints[i+1]; j++) { ohlc_real[1] = MAX(ohlc_real[1], x_real[j + Hi*nrx]); /* HI */ ohlc_real[2] = MIN(ohlc_real[2], x_real[j + Lo*nrx]); /* LO */ if(_hasVolume) { ohlc_real[4] = ohlc_real[4] + x_real[j + Vo*nrx]; /* VO */ } } break; } /* set the Close and Adjusted columns */ /* Rprintf("i,j: %i,%i\t",i,j); */ j--; switch(mode) { case INTSXP: ohlc_int[3] = x_int[j + Cl*nrx]; if(_hasAdjusted) ohlc_int[5] = x_int[j + 5*nrx]; break; case REALSXP: ohlc_real[3] = x_real[j + Cl*nrx]; if(_hasAdjusted) ohlc_real[5] = x_real[j + 5*nrx]; break; } if(!_FIRST) { /* index at last position */ switch(index_mode) { case INTSXP: INTEGER(newindex)[i] = INTEGER(xindex)[j]; break; case REALSXP: REAL(newindex)[i] = REAL(xindex)[j]; break; } } /* switch(mode) { case INTSXP: INTEGER(result)[i] = ohlc_int[0]; INTEGER(result)[i+1*n] = ohlc_int[1]; INTEGER(result)[i+2*n] = ohlc_int[2]; INTEGER(result)[i+3*n] = ohlc_int[3]; if(_hasVolume) INTEGER(result)[i+4*n] = ohlc_int[4]; if(_hasAdjusted) INTEGER(result)[i+5*n] = ohlc_int[5]; break; case REALSXP: REAL(result)[i] = REAL(ohlc)[0]; REAL(result)[i+1*n] = REAL(ohlc)[1]; REAL(result)[i+2*n] = REAL(ohlc)[2]; REAL(result)[i+3*n] = REAL(ohlc)[3]; if(_hasVolume) REAL(result)[i+4*n] = REAL(ohlc)[4]; if(_hasAdjusted) REAL(result)[i+5*n] = REAL(ohlc)[5]; break; } */ switch(mode) { case INTSXP: result_int[i] = ohlc_int[0]; result_int[i+1*n] = ohlc_int[1]; result_int[i+2*n] = ohlc_int[2]; result_int[i+3*n] = ohlc_int[3]; if(_hasVolume) result_int[i+4*n] = ohlc_int[4]; if(_hasAdjusted) result_int[i+5*n] = ohlc_int[5]; break; case REALSXP: result_real[i] = ohlc_real[0]; result_real[i+1*n] = ohlc_real[1]; result_real[i+2*n] = ohlc_real[2]; result_real[i+3*n] = ohlc_real[3]; if(_hasVolume) result_real[i+4*n] = ohlc_real[4]; if(_hasAdjusted) result_real[i+5*n] = ohlc_real[5]; break; } /* Rprintf("i,j: %i,%i\n",i,j); */ } SEXP dim; dim = PROTECT(allocVector(INTSXP, 2)); P++; INTEGER(dim)[0] = n; INTEGER(dim)[1] = ncr; setAttrib(result, R_DimSymbol, dim); PROTECT(dimnames = allocVector(VECSXP, 2)); P++; SET_VECTOR_ELT(dimnames, 0, R_NilValue); /* no rownames ever! */ if(!isNull(colnames)) { SET_VECTOR_ELT(dimnames, 1, colnames); } else { SEXP newcolnames; PROTECT(newcolnames = allocVector(STRSXP, ncr));P++; SET_STRING_ELT(newcolnames, 0, mkChar("Open")); SET_STRING_ELT(newcolnames, 1, mkChar("High")); SET_STRING_ELT(newcolnames, 2, mkChar("Low")); SET_STRING_ELT(newcolnames, 3, mkChar("Close")); if(INTEGER(hasVolume)[0]) SET_STRING_ELT(newcolnames, 4, mkChar("Volume")); if(INTEGER(hasAdjusted)[0]) SET_STRING_ELT(newcolnames, 5, mkChar("Adjusted")); SET_VECTOR_ELT(dimnames, 1, newcolnames); } setAttrib(result, R_DimNamesSymbol, dimnames); copyMostAttrib(xindex, newindex); setAttrib(result, xts_IndexSymbol, newindex); copy_xtsAttributes(x, result); copy_xtsCoreAttributes(x, result); UNPROTECT(P); return result; } xts/src/period_quantile.c0000644000176200001440000000440113564762102015214 0ustar liggesusers/* # xts: eXtensible time-series # # Copyright (C) 2008 Jeffrey A. Ryan (FORTRAN implementation) # Copyright (C) 2018 Joshua M. Ulrich (C implementation) # # 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 . */ #include SEXP xts_period_max(SEXP _data, SEXP _index) { if (ncols(_data) > 1) { error("single column data only"); } if (!isInteger(_index)) { error("index must be integer"); } if (!isReal(_data)) { error("data must be double"); } int i, j; int n = length(_index) - 1; SEXP _result = PROTECT(allocVector(REALSXP, n)); double *result = REAL(_result); int *index = INTEGER(_index); double *data = REAL(_data); int k = 0; for (i = 0; i < n; i++) { int idx0 = index[i]; int idx1 = index[i + 1]; double max = data[idx0]; for (j = idx0+1; j < idx1; j++) { if (data[j] > max) { max = data[j]; } } result[k++] = max; } UNPROTECT(1); return _result; } SEXP xts_period_min(SEXP _data, SEXP _index) { if (ncols(_data) > 1) { error("single column data only"); } if (!isInteger(_index)) { error("index must be integer"); } if (!isReal(_data)) { error("data must be double"); } int i, j; int n = length(_index) - 1; SEXP _result = PROTECT(allocVector(REALSXP, n)); double *result = REAL(_result); int *index = INTEGER(_index); double *data = REAL(_data); int k = 0; for (i = 0; i < n; i++) { int idx0 = index[i]; int idx1 = index[i + 1]; double min = data[idx0]; for (j = idx0+1; j < idx1; j++) { if (data[j] < min) { min = data[j]; } } result[k++] = min; } UNPROTECT(1); return _result; } xts/src/subset.c0000644000176200001440000003433013564762102013341 0ustar liggesusers/* # 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 . */ #include #include #include "xts.h" static SEXP xts_ExtractSubset(SEXP x, SEXP result, SEXP indx) //, SEXP call) { /* ExtractSubset is currently copied/inspired by subset.c from GNU-R This is slated to be reimplemented using the previous method in xts to get the correct dimnames */ int i, ii, n, nx, mode; SEXP tmp, tmp2; mode = TYPEOF(x); n = LENGTH(indx); nx = length(x); tmp = result; /*if (x == R_NilValue)*/ if (isNull(x)) return x; for (i = 0; i < n; i++) { ii = INTEGER(indx)[i]; if (ii != NA_INTEGER) ii--; switch (mode) { case LGLSXP: if (0 <= ii && ii < nx && ii != NA_LOGICAL) LOGICAL(result)[i] = LOGICAL(x)[ii]; else LOGICAL(result)[i] = NA_LOGICAL; break; case INTSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) INTEGER(result)[i] = INTEGER(x)[ii]; else INTEGER(result)[i] = NA_INTEGER; break; case REALSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) REAL(result)[i] = REAL(x)[ii]; else REAL(result)[i] = NA_REAL; break; case CPLXSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) { COMPLEX(result)[i] = COMPLEX(x)[ii]; } else { COMPLEX(result)[i].r = NA_REAL; COMPLEX(result)[i].i = NA_REAL; } break; case STRSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) SET_STRING_ELT(result, i, STRING_ELT(x, ii)); else SET_STRING_ELT(result, i, NA_STRING); break; case VECSXP: case EXPRSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) SET_VECTOR_ELT(result, i, VECTOR_ELT(x, ii)); else SET_VECTOR_ELT(result, i, R_NilValue); break; case LISTSXP: /* cannot happen: pairlists are coerced to lists */ case LANGSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) { tmp2 = nthcdr(x, ii); SETCAR(tmp, CAR(tmp2)); SET_TAG(tmp, TAG(tmp2)); } else SETCAR(tmp, R_NilValue); tmp = CDR(tmp); break; case RAWSXP: if (0 <= ii && ii < nx && ii != NA_INTEGER) RAW(result)[i] = RAW(x)[ii]; else RAW(result)[i] = (Rbyte) 0; break; default: error("error in subset\n"); break; } } return result; } SEXP _do_subset_xts (SEXP x, SEXP sr, SEXP sc, SEXP drop) { SEXP result; int i, j, nr, nc, nrs, ncs; int P=0; SEXP Dim = getAttrib(x, R_DimSymbol); nrs = nrows(x);ncs = ncols(x); nr = length(sr); nc = length(sc); SEXP oindex, nindex; oindex = getAttrib(x, xts_IndexSymbol); PROTECT(nindex = allocVector(TYPEOF(oindex), nr)); P++; PROTECT(result = allocVector(TYPEOF(x), nr*nc)); P++; j = 0; double *real_nindex=NULL, *real_oindex, *real_result=NULL, *real_x=NULL; int *int_nindex=NULL, *int_oindex, *int_result=NULL, *int_x=NULL; int *int_sr=NULL, *int_sc=NULL; int_sr = INTEGER(sr); int_sc = INTEGER(sc); copyAttributes(x, result); if(TYPEOF(x)==LGLSXP) { int_x = LOGICAL(x); int_result = LOGICAL(result); if(TYPEOF(nindex)==INTSXP) { int_nindex = INTEGER(nindex); int_oindex = INTEGER(oindex); for(i=0; i nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); int_nindex[i] = int_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) int_result[i+j*nr] = NA_INTEGER; else int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)]; } } else if(TYPEOF(nindex)==REALSXP) { real_nindex = REAL(nindex); real_oindex = REAL(oindex); for(i=0; i nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); real_nindex[i] = real_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) int_result[i+j*nr] = NA_INTEGER; else int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)]; } } copyAttributes(oindex, nindex); setAttrib(result, xts_IndexSymbol, nindex); for(j=1; j nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); int_nindex[i] = int_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) int_result[i+j*nr] = NA_INTEGER; else int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)]; } } else if(TYPEOF(nindex)==REALSXP) { real_nindex = REAL(nindex); real_oindex = REAL(oindex); for(i=0; i nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); real_nindex[i] = real_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) int_result[i+j*nr] = NA_INTEGER; else int_result[i+j*nr] = int_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)]; } } copyAttributes(oindex, nindex); setAttrib(result, xts_IndexSymbol, nindex); /* loop through remaining columns */ for(j=1; j nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); int_nindex[i] = int_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) real_result[i+j*nr] = NA_REAL; else real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)]; } } else if(TYPEOF(nindex)==REALSXP) { real_nindex = REAL(nindex); real_oindex = REAL(oindex); for(i=0; i nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); real_nindex[i] = real_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) real_result[i+j*nr] = NA_REAL; else real_result[i+j*nr] = real_x[int_sr[i]-1 + ((int_sc[j]-1) * nrs)]; } } copyAttributes(oindex, nindex); setAttrib(result, xts_IndexSymbol, nindex); for(j=1; j nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); int_nindex[i] = int_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) { COMPLEX(result)[i+j*nr].r = NA_REAL; COMPLEX(result)[i+j*nr].i = NA_REAL; } else COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)]; } } else if(TYPEOF(nindex)==REALSXP) { real_nindex = REAL(nindex); real_oindex = REAL(oindex); for(i=0; i nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); real_nindex[i] = real_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) { COMPLEX(result)[i+j*nr].r = NA_REAL; COMPLEX(result)[i+j*nr].i = NA_REAL; } else COMPLEX(result)[i+j*nr] = COMPLEX(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)]; } } copyAttributes(oindex, nindex); setAttrib(result, xts_IndexSymbol, nindex); for(j=1; j nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); int_nindex[i] = int_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) SET_STRING_ELT(result, i+j*nr, NA_STRING); else SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs))); } } else if(TYPEOF(nindex)==REALSXP) { real_nindex = REAL(nindex); real_oindex = REAL(oindex); for(i=0; i nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); real_nindex[i] = real_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) SET_STRING_ELT(result, i+j*nr, NA_STRING); else SET_STRING_ELT(result, i+j*nr, STRING_ELT(x, int_sr[i]-1 + ((int_sc[j]-1) * nrs))); } } copyAttributes(oindex, nindex); setAttrib(result, xts_IndexSymbol, nindex); for(j=1; j nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); int_nindex[i] = int_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) RAW(result)[i+j*nr] = 0; else RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)]; } } else if(TYPEOF(nindex)==REALSXP) { real_nindex = REAL(nindex); real_oindex = REAL(oindex); for(i=0; i nrs || int_sc[j] > ncs) error("'i' or 'j' out of range"); real_nindex[i] = real_oindex[int_sr[i]-1]; if(int_sc[j] == NA_INTEGER) RAW(result)[i+j*nr] = 0; else RAW(result)[i+j*nr] = RAW(x)[int_sr[i]-1 + ((int_sc[j]-1) * nrs)]; } } copyAttributes(oindex, nindex); setAttrib(result, xts_IndexSymbol, nindex); for(j=1; j= 0 && nc >= 0) { SEXP dim; PROTECT(dim = allocVector(INTSXP,2));P++; INTEGER(dim)[0] = nr; INTEGER(dim)[1] = nc; setAttrib(result, R_DimSymbol, dim); if (nr >= 0 && nc >= 0) { SEXP dimnames, dimnamesnames, newdimnames; dimnames = getAttrib(x, R_DimNamesSymbol); dimnamesnames = getAttrib(dimnames, R_NamesSymbol); if (!isNull(dimnames)) { PROTECT(newdimnames = allocVector(VECSXP, 2)); if (TYPEOF(dimnames) == VECSXP) { SET_VECTOR_ELT(newdimnames, 0, xts_ExtractSubset(VECTOR_ELT(dimnames, 0), allocVector(STRSXP, nr), sr)); SET_VECTOR_ELT(newdimnames, 1, xts_ExtractSubset(VECTOR_ELT(dimnames, 1), allocVector(STRSXP, nc), sc)); } else { SET_VECTOR_ELT(newdimnames, 0, xts_ExtractSubset(CAR(dimnames), allocVector(STRSXP, nr), sr)); SET_VECTOR_ELT(newdimnames, 1, xts_ExtractSubset(CADR(dimnames), allocVector(STRSXP, nc), sc)); } setAttrib(newdimnames, R_NamesSymbol, dimnamesnames); setAttrib(result, R_DimNamesSymbol, newdimnames); UNPROTECT(1); } } } setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol)); if(nc == 1 && LOGICAL(drop)[0]) setAttrib(result, R_DimSymbol, R_NilValue); UNPROTECT(P); return result; } xts/src/dimnames.c0000644000176200001440000000254113564762102013630 0ustar liggesusers/* # xts: eXtensible time-series # # Copyright (C) 2010 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 . */ #include #include SEXP dimnames_zoo (SEXP x) { return(getAttrib(x, R_DimNamesSymbol)); } SEXP xts_set_dimnames (SEXP x, SEXP value) { if (R_NilValue == value) { setAttrib(x, R_DimNamesSymbol, R_NilValue); } else { if (TYPEOF(value) != VECSXP || length(value) != 2) { error("invalid 'dimnames' given for xts"); } /* xts objects never have row names */ if (MAYBE_SHARED(value)) { value = duplicate(value); } SET_VECTOR_ELT(value, 0, R_NilValue); setAttrib(x, R_DimNamesSymbol, value); } return x; } xts/src/init.c0000644000176200001440000001212113607327622012773 0ustar liggesusers/* # xts: eXtensible time-series # # Copyright (C) 2008 - 2013 Jeffrey A. Ryan jeff.a.ryan @ gmail.com # # Contributions from Joshua M. Ulrich and Dirk Eddelbuettel # # 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 . */ #include "xts.h" #include #include #include static const R_CallMethodDef callMethods[] = { {"add_class", (DL_FUNC) &add_class, 2}, {"coredata", (DL_FUNC) &coredata, 2}, {"coredata_xts", (DL_FUNC) &coredata_xts, 1}, {"do_xtsAttributes", (DL_FUNC) &do_xtsAttributes, 1}, {"do_xtsCoreAttributes", (DL_FUNC) &do_xtsCoreAttributes, 1}, {"lagXts", (DL_FUNC) &lagXts, 3}, {"do_is_ordered", (DL_FUNC) &do_is_ordered, 3}, {"isXts", (DL_FUNC) &isXts, 1}, {"tryXts", (DL_FUNC) &tryXts, 1}, {"do_rbind_xts", (DL_FUNC) &do_rbind_xts, 3}, {"do_subset_xts", (DL_FUNC) &do_subset_xts, 4}, {"naCheck", (DL_FUNC) &naCheck, 2}, {"xts_period_min", (DL_FUNC) &xts_period_min, 2}, {"xts_period_max", (DL_FUNC) &xts_period_max, 2}, {"xts_period_sum", (DL_FUNC) &xts_period_sum, 2}, {"xts_period_prod", (DL_FUNC) &xts_period_prod, 2}, {"xts_set_dimnames", (DL_FUNC) &xts_set_dimnames, 2}, {NULL, NULL, 0} }; static const R_ExternalMethodDef externalMethods[] = { {"number_of_cols", (DL_FUNC) &number_of_cols, -1}, {"mergeXts", (DL_FUNC) &mergeXts, -1}, {"rbindXts", (DL_FUNC) &rbindXts, -1}, {NULL, NULL, 0} }; /* define globals */ SEXP xts_IndexSymbol; SEXP xts_ClassSymbol; SEXP xts_IndexTformatSymbol; SEXP xts_IndexTclassSymbol; SEXP xts_IndexTzoneSymbol; /* define imports from zoo */ SEXP (*zoo_lag)(SEXP,SEXP,SEXP); SEXP (*zoo_coredata)(SEXP,SEXP); /* * Taken from R/src/main/names.c * "Set up a set of globals so that a symbol table search can be * avoided when matching something like dim or dimnames." * * This also prevents flags from rchk's maacheck (Multiple-Allocating- * Arguments) tool for calls like: * setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol)); */ static void SymbolShortcuts(void) { xts_IndexSymbol = install("index"); xts_ClassSymbol = install(".CLASS"); xts_IndexTformatSymbol = install("tformat"); xts_IndexTclassSymbol = install("tclass"); xts_IndexTzoneSymbol = install("tzone"); } void R_init_xts(DllInfo *info) { SymbolShortcuts(); R_registerRoutines(info, NULL, callMethods, NULL, externalMethods); R_useDynamicSymbols(info, TRUE); /* used by external packages linking to internal xts code from C */ R_RegisterCCallable("xts","do_is_ordered",(DL_FUNC) &do_is_ordered); R_RegisterCCallable("xts","coredata_xts", (DL_FUNC) &coredata_xts); R_RegisterCCallable("xts","isXts", (DL_FUNC) &isXts); R_RegisterCCallable("xts","tryXts", (DL_FUNC) &tryXts); R_RegisterCCallable("xts","do_rbind_xts", (DL_FUNC) &do_rbind_xts); R_RegisterCCallable("xts","naCheck", (DL_FUNC) &naCheck); R_RegisterCCallable("xts","lagXts", (DL_FUNC) &lagXts); R_RegisterCCallable("xts","make_index_unique", (DL_FUNC) &make_index_unique); R_RegisterCCallable("xts","make_unique", (DL_FUNC) &make_unique); R_RegisterCCallable("xts","endpoints", (DL_FUNC) &endpoints); R_RegisterCCallable("xts","do_merge_xts", (DL_FUNC) &do_merge_xts); R_RegisterCCallable("xts","na_omit_xts", (DL_FUNC) &na_omit_xts); R_RegisterCCallable("xts","na_locf", (DL_FUNC) &na_locf); R_RegisterCCallable("xts","xts_period_min", (DL_FUNC) &xts_period_min); R_RegisterCCallable("xts","xts_period_max", (DL_FUNC) &xts_period_max); R_RegisterCCallable("xts","xts_period_sum", (DL_FUNC) &xts_period_sum); R_RegisterCCallable("xts","xts_period_prod", (DL_FUNC) &xts_period_prod); R_RegisterCCallable("xts","xts_set_dimnames", (DL_FUNC) &xts_set_dimnames); /* used by xts (functions moved from xts to zoo) */ zoo_lag = (SEXP(*)(SEXP,SEXP,SEXP)) R_GetCCallable("zoo","zoo_lag"); zoo_coredata = (SEXP(*)(SEXP,SEXP)) R_GetCCallable("zoo","zoo_coredata"); } xts/src/attr.c0000644000176200001440000001233413564762102013006 0ustar liggesusers/* # 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 . */ #include #include #include #include "xts.h" SEXP do_xtsAttributes(SEXP x) { SEXP a, values, names; int i=0, P=0; a = ATTRIB(x); if(length(a) <= 0) return R_NilValue; PROTECT(a); P++; /* all attributes */ PROTECT(values = allocVector(VECSXP, length(a))); P++; PROTECT(names = allocVector(STRSXP, length(a))); P++; /* CAR gets the first element of the dotted pair list CDR gets the rest of the dotted pair list TAG gets the symbol/name of the first element of dotted pair list */ for( /* a=ATTRIB(a) */; a != R_NilValue; a = CDR(a) ) { if(TAG(a) != xts_IndexSymbol && TAG(a) != xts_ClassSymbol && TAG(a) != R_ClassSymbol && TAG(a) != R_DimSymbol && TAG(a) != R_DimNamesSymbol && TAG(a) != R_NamesSymbol) { SET_VECTOR_ELT(values, i, CAR(a)); SET_STRING_ELT(names, i, PRINTNAME(TAG(a))); i++; } } if(i == 0) { UNPROTECT(P); return R_NilValue; } /* truncate list back to i-size */ PROTECT(values = lengthgets(values, i)); P++; PROTECT(names = lengthgets(names, i)); P++; setAttrib(values, R_NamesSymbol, names); UNPROTECT(P); return values; } SEXP do_xtsCoreAttributes(SEXP x) { SEXP a, values, names; int i=0, P=0; a = ATTRIB(x); if(length(a) <= 0) return R_NilValue; PROTECT(a); P++; /* all attributes */ PROTECT(values = allocVector(VECSXP, length(a))); P++; PROTECT(names = allocVector(STRSXP, length(a))); P++; /* CAR gets the first element of the dotted pair list CDR gets the rest of the dotted pair list TAG gets the symbol/name of the first element of dotted pair list */ for( /* a=ATTRIB(a) */; a != R_NilValue; a = CDR(a) ) { if(TAG(a) == xts_ClassSymbol || TAG(a) == R_ClassSymbol) { SET_VECTOR_ELT(values, i, CAR(a)); SET_STRING_ELT(names, i, PRINTNAME(TAG(a))); i++; } } if(i == 0) { UNPROTECT(P); return R_NilValue; } /* truncate list back to i-size */ PROTECT(values = lengthgets(values, i)); P++; PROTECT(names = lengthgets(names, i)); P++; setAttrib(values, R_NamesSymbol, names); UNPROTECT(P); return values; } void copyAttributes(SEXP x, SEXP y) { /* similar to copyMostAttr except that we add index to the list of attributes to exclude */ SEXP attr; int P=0; attr = ATTRIB(x); /* this returns a LISTSXP */ if(length(attr) > 0 || y != R_NilValue) { PROTECT(attr); P++; for( ; attr != R_NilValue; attr = CDR(attr) ) { if( (TAG(attr) != xts_IndexSymbol) && (TAG(attr) != R_DimSymbol) && (TAG(attr) != R_DimNamesSymbol) && (TAG(attr) != R_NamesSymbol) ) { setAttrib(y, TAG(attr), CAR(attr)); } } UNPROTECT(P); } } void copy_xtsAttributes(SEXP x, SEXP y) { SEXP attr; int P=0; attr = PROTECT(do_xtsAttributes(x)); P++; attr = PROTECT(coerceVector(attr, LISTSXP)); P++; if(length(attr) > 0 || y != R_NilValue) { for( ; attr != R_NilValue; attr = CDR(attr) ) { setAttrib(y, TAG(attr), CAR(attr)); } } UNPROTECT(P); } void copy_xtsCoreAttributes(SEXP x, SEXP y) { SEXP attr; int P=0; attr = PROTECT(do_xtsCoreAttributes(x)); P++; attr = PROTECT(coerceVector(attr, LISTSXP)); P++; if(length(attr) > 0 || y != R_NilValue) { for( ; attr != R_NilValue; attr = CDR(attr) ) { setAttrib(y, TAG(attr), CAR(attr)); } } UNPROTECT(P); } SEXP ca (SEXP x, SEXP y) { /* an example of internal copying of user-defined xts attributes this will be used inside of do_xts_subset and do_xts_merge This particular usage is bad, as y is modified without copying resulting in all y and reference to y within R envir being altered the 'y' should only be the new value that is to be returned */ copy_xtsAttributes(x,y); return R_NilValue; } SEXP add_xtsCoreAttributes(SEXP _x, SEXP _index, SEXP _tzone, SEXP _tclass, SEXP _class, SEXP _tformat) { int P=0; if(MAYBE_SHARED(_index)) { PROTECT(_index = duplicate(_index)); P++; } /* add tzone and tclass to index */ setAttrib(_index, xts_IndexTclassSymbol, _tclass); setAttrib(_index, xts_IndexTzoneSymbol, _tzone); setAttrib(_index, xts_IndexTformatSymbol, _tformat); if(MAYBE_SHARED(_x)) { PROTECT(_x = duplicate(_x)); P++; //_x = duplicate(_x); } setAttrib(_x, xts_IndexSymbol, _index); /* index */ setAttrib(_x, R_ClassSymbol, _class); /* class */ UNPROTECT(P); return(_x); } xts/src/rollfun.c0000644000176200001440000003124413564762102013516 0ustar liggesusers/* # 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 . */ #include #include #include "xts.h" /* http://en.wikipedia.org/wiki/Kahan_summation_algorithm * sum += x, and updates the accumulated error "c" */ void kahan_sum(long double x, long double * c, long double * sum) { /* Author: Ivan Popivanov */ long double y = x - *c; long double t = *sum + y; *c = ( t - *sum ) - y; *sum = t; } SEXP roll_sum (SEXP x, SEXP n) { /* Author: Joshua Ulrich, with contributions from Ivan Popivanov */ int i, P=0, nrs; nrs = nrows(x); /* Get values from pointers */ int int_n = asInteger(n); /* Initalize result R object */ SEXP result; PROTECT(result = allocVector(TYPEOF(x), length(x))); P++; int *int_result=NULL, *int_x=NULL; int int_sum = 0; double *real_result=NULL, *real_x=NULL; /* check for non-leading NAs and get first non-NA location */ SEXP first; PROTECT(first = naCheck(x, ScalarLogical(TRUE))); P++; int int_first = asInteger(first); if(int_n + int_first > nrs) error("not enough non-NA values"); long double sum = 0.0; long double comp = 0.0; switch(TYPEOF(x)) { case REALSXP: real_result = REAL(result); real_x = REAL(x); //int_result = int_x = NULL; /* set leading NAs, find initial sum value */ for(i=0; i= int_first) kahan_sum(real_x[i], &comp, &sum); } real_result[ int_n + int_first - 1 ] = (double)sum; /* loop over all other values */ for(i=int_n+int_first; i= int_first) int_sum += int_x[i]; } int_result[ int_n + int_first -1 ] = int_sum; /* loop over all other values */ for(i=int_n+int_first; i nrs) error("not enough non-NA values"); /* The branch by type allows for fewer type checks/branching * within the algorithm, providing a _much_ faster mechanism */ switch(TYPEOF(x)) { /* need to implement other types (checking)? */ case REALSXP: real_result = REAL(result); real_x = REAL(x); real_min = real_x[0]; loc = 0; for(i=0; i= int_n-1) { /* find the min over the entire window */ real_min = real_x[i]; for(j=0; j= int_n - 1) { /* find the min over the entire window */ int_min = int_x[i]; for(j=0; j nrs) error("not enough non-NA values"); /* The branch by type allows for fewer type checks/branching * within the algorithm, providing a _much_ faster mechanism */ switch(TYPEOF(x)) { /* need to implement other types (checking)? */ case REALSXP: real_result = REAL(result); real_x = REAL(x); real_max = real_x[0]; loc = 0; for(i=0; i real_max) { real_max = real_x[i]; /* set min value */ loc = 0; /* set min location in window */ } loc++; continue; } else { /* if the min leaves the window */ if(loc >= int_n-1) { /* find the min over the entire window */ real_max = real_x[i]; for(j=0; j real_max) { real_max = real_x[i-j]; loc = j; } } } else { /* if the new value is the new min */ if(real_x[i] > real_max) { real_max = real_x[i]; loc = 0; } } } /* set result, increment location */ real_result[i] = real_max; loc++; } break; case INTSXP: int_result = INTEGER(result); int_x = INTEGER(x); int_min = int_x[0]; loc = 0; for(i=0; i int_min) { int_min = int_x[i]; /* set min value */ loc = 0; /* set min location in window */ } loc++; continue; } else { /* if the min leaves the window */ if(loc >= int_n - 1) { /* find the min over the entire window */ int_min = int_x[i]; for(j=0; j int_min) { int_min = int_x[i-j]; loc = j; } } } else { /* if the new value is the new min */ if(int_x[i] > int_min) { int_min = int_x[i]; loc = 0; } } } /* set result, increment location */ int_result[i] = int_min; loc++; } break; /* case STRSXP: fail! case LGLSXP: convert to int?? case CPLXSXP: */ default: error("unsupported data type"); } copyMostAttrib(x, result); /* still need to set dims and dimnames */ setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol)); setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(P); return result; } SEXP roll_cov (SEXP x, SEXP y, SEXP n, SEXP samp) { /* Author: Joshua Ulrich */ int i, P=0; /* ensure x and y have same length in R functions, since it's * easier to throw user-informative errors */ int nrx = nrows(x); int nry = nrows(y); if(nrx != nry) error("nrx != nry, blame the R function writer"); /* Coerce to REALSXP to ensure roll_sum returns REALSXP */ PROTECT(x = coerceVector(x, REALSXP)); P++; PROTECT(y = coerceVector(y, REALSXP)); P++; /* Get values from function arguments */ double *real_x = REAL(PROTECT(coerceVector(x, REALSXP))); P++; double *real_y = REAL(PROTECT(coerceVector(y, REALSXP))); P++; int int_n = asInteger(n); int int_samp = asLogical(samp); /* Initalize result R object */ SEXP result; PROTECT(result = allocVector(REALSXP, nrx)); P++; double *real_result = REAL(result); /* rolling sums for mean calculation */ SEXP sum_x, sum_y, xy, sum_xy; PROTECT(sum_x = roll_sum(x, n)); P++; PROTECT(sum_y = roll_sum(y, n)); P++; double *real_sum_x = REAL(sum_x); double *real_sum_y = REAL(sum_y); /* rolling sum of x * y */ PROTECT(xy = allocVector(REALSXP, nrx)); P++; double *real_xy = REAL(xy); for(i=nrx; i--;) { real_xy[i] = real_x[i] * real_y[i]; } PROTECT(sum_xy = roll_sum(xy, n)); P++; double *real_sum_xy = REAL(sum_xy); /* check for non-leading NAs and get first non-NA location */ SEXP first; PROTECT(first = naCheck(sum_xy, ScalarLogical(TRUE))); P++; int int_first = asInteger(first); if(int_n + int_first > nrx) error("not enough non-NA values"); /* set leading NAs */ for(i=0; i. */ /***********************************************************************/ /* xts, copyright (C) Jeffrey A. Ryan, 2008 */ // // experimental code to provide rollapply functionality to standard // functions. Essentially a .Call port of Josh's run*** functions // from TTR. Though it should be obvious these are a lot more complex. // // runSum, runMin, runMax, runMedian, runMean, runSD // /***********************************************************************/ #include #include #include "xts.h" /* SEXP do_runsum (SEXP x, SEXP n, SEXP result) { } SEXP do_run (SEXP x, SEXP n, (*void)FUN) { SEXP result; int P=0; int i, nrs; int *int_n=NULL; if(TYPEOF(n) != INTSXP) { // assure that 'n' is an integer PROTECT(n = coerceVector(n, INTSXP)); P++; } int_n = INTEGER(n); // get the first element (everything from R is a vector) int *int_result=NULL, *int_x=NULL; int int_sum = 0; double *real_result=NULL, *real_x=NULL; double real_sum = 0.0; PROTECT(result = allocVector(TYPEOF(x), length(x))); P++; int _firstNonNA = firstNonNA(x); } */ SEXP runSum (SEXP x, SEXP n) { SEXP result; int P=0; int i, nrs; int *int_n=NULL; if(TYPEOF(n) != INTSXP) { // assure that 'n' is an integer PROTECT(n = coerceVector(n, INTSXP)); P++; } int_n = INTEGER(n); // get the first element (everything from R is a vector) int *int_result=NULL, *int_x=NULL; int int_sum = 0; double *real_result=NULL, *real_x=NULL; double real_sum = 0.0; PROTECT(result = allocVector(TYPEOF(x), length(x))); P++; int _firstNonNA = firstNonNA(x); switch(TYPEOF(x)) { /* still need to implement other types, and checking // The branch by type allows for fewer type checks/branching // within the algorithm, providing a _much_ faster mechanism // to calculate the sum // // This part of the code should probably be a function // call to a function pointer passed in to the top-level // call... maybe??? // This should make it easier to extend the framework // and _more_ importantly allow for user-level C // functions (via R) to be used ad hoc */ case REALSXP: real_result = REAL(result); real_x = REAL(x); int_result = int_x = NULL; for(i = 0; i < (*int_n)+_firstNonNA; i++) { real_result[i] = NA_REAL; if(i >= _firstNonNA) real_sum = real_sum + real_x[i]; } real_result[ (*int_n) + _firstNonNA - 1 ] = real_sum; nrs = nrows(x); for(i = (*int_n)+_firstNonNA; i < nrs; i++) { if(ISNA(real_x[i]) || ISNAN(real_x[i])) error("Series contains non-leading NAs"); real_result[i] = real_result[i-1] + real_x[i] - real_x[i-(*int_n)]; } break; case INTSXP: int_result = INTEGER(result); int_x = INTEGER(x); real_result = real_x = NULL; for(i = 0; i < (*int_n)+_firstNonNA; i++) { // (*int_n) is faster that INTEGER(n)[1], a constant would be equal int_result[i] = NA_INTEGER; if(i >= _firstNonNA) int_sum = int_sum + int_x[i]; } int_result[ (*int_n) + _firstNonNA -1 ] = int_sum; nrs = nrows(x); for(i = (*int_n)+_firstNonNA; i < nrs; i++) { if(int_x[i]==NA_INTEGER) error("Series contains non-leading NAs"); int_result[i] = int_result[i-1] + int_x[i] - int_x[i-(*int_n)]; } break; /* case STRSXP: fail! case LGLSXP: convert to int?? case CPLXSXP: */ } setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol)); setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol)); setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol)); UNPROTECT(P); return result; } xts/src/na.c0000644000176200001440000003676513564762102012450 0ustar liggesusers/* # 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 . */ #include #include #include #include "xts.h" /* Internal use only * called by: firstNonNA, naCheck, na_locf */ static int firstNonNACol (SEXP x, int col) { int i=0, nr; int *int_x=NULL; double *real_x=NULL; nr = nrows(x); if(col > ncols(x)-1 || col < 0L) error("column out of range"); switch(TYPEOF(x)) { case LGLSXP: int_x = LOGICAL(x); for(i=0+col*nr; i<(nr+col*nr); i++) { if(int_x[i]!=NA_LOGICAL) { break; } } break; case INTSXP: int_x = INTEGER(x); for(i=0+col*nr; i<(nr+col*nr); i++) { if(int_x[i]!=NA_INTEGER) { break; } } break; case REALSXP: real_x = REAL(x); for(i=0+col*nr; i<(nr+col*nr); i++) { if(!ISNA(real_x[i]) && !ISNAN(real_x[i])) { break; } } break; case STRSXP: for(i=0+col*nr; i<(nr+col*nr); i++) { if(STRING_ELT(x, i)!=NA_STRING) { break; } } break; default: error("unsupported type"); break; } return(i); } /* Should be internal use only (static), but is in xts.h */ int firstNonNA (SEXP x) { return firstNonNACol(x, 0); } SEXP naCheck (SEXP x, SEXP check) { /* Check for non-leading NA values, throw error if found */ SEXP first; int _first; _first = firstNonNA(x); PROTECT(first = allocVector(INTSXP, 1)); INTEGER(first)[0] = _first; if(LOGICAL(check)[0]) { /* check for NAs in rest of data */ int i, nr; int *int_x = NULL; double *real_x = NULL; nr = nrows(x); switch(TYPEOF(x)) { case LGLSXP: int_x = LOGICAL(x); for(i=_first; i (int)maxgap) { /* check that we don't have excessive trailing gap */ for(ii = i-1; ii > i-gap-1; ii--) { int_result[ii] = NA_LOGICAL; } } } } else { /* nr-2 is first position to fill fromLast=TRUE */ for(j=0; j < nc; j++) { int_result[nr-1+j*nr] = int_x[nr-1+j*nr]; gap = 0; for(i=nr-2 + j*nr; i>=0+j*nr; i--) { int_result[i] = int_x[i]; if(int_result[i] == NA_LOGICAL && gap < maxgap) { int_result[i] = int_result[i+1]; gap++; } } } } break; case INTSXP: int_x = INTEGER(x); int_result = INTEGER(result); if(!LOGICAL(fromLast)[0]) { for(j=0; j < nc; j++) { /* copy leading NAs */ _first = firstNonNACol(x, j); if (_first == nr + j*nr) _first--; for(i=0+j*nr; i < (_first+1); i++) { int_result[i] = int_x[i]; } /* result[_first] now has first value fromLast=FALSE */ gap = 0; for(i=_first+1; i gap) int_result[i] = int_result[i-1]; gap++; } else { if((int)gap > (int)maxgap) { for(ii = i-1; ii > i-gap-1; ii--) { int_result[ii] = NA_INTEGER; } } gap=0; } } if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */ for(ii = i-1; ii > i-gap-1; ii--) { int_result[ii] = NA_INTEGER; } } } } else { /* nr-2 is first position to fill fromLast=TRUE */ for(j=0; j < nc; j++) { int_result[nr-1+j*nr] = int_x[nr-1+j*nr]; gap = 0; for(i=nr-2 + j*nr; i>=0+j*nr; i--) { int_result[i] = int_x[i]; if(int_result[i] == NA_INTEGER) { if(limit > gap) int_result[i] = int_result[i+1]; gap++; } else { if((int)gap > (int)maxgap) { for(ii = i+1; ii < i+gap+1; ii++) { int_result[ii] = NA_INTEGER; } } gap=0; } } if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */ for(ii = i+1; ii < i+gap+1; ii++) { int_result[ii] = NA_INTEGER; } } } } break; case REALSXP: real_x = REAL(x); real_result = REAL(result); if(!LOGICAL(fromLast)[0]) { /* fromLast=FALSE */ for(j=0; j < nc; j++) { /* copy leading NAs */ _first = firstNonNACol(x, j); if (_first == nr + j*nr) _first--; for(i=0+j*nr; i < (_first+1); i++) { real_result[i] = real_x[i]; } /* result[_first] now has first value fromLast=FALSE */ gap = 0; for(i=_first+1; i gap) real_result[i] = real_result[i-1]; gap++; } else { if((int)gap > (int)maxgap) { for(ii = i-1; ii > i-gap-1; ii--) { real_result[ii] = NA_REAL; } } gap=0; } } if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */ for(ii = i-1; ii > i-gap-1; ii--) { real_result[ii] = NA_REAL; } } } } else { /* fromLast=TRUE */ for(j=0; j < nc; j++) { real_result[nr-1+j*nr] = real_x[nr-1+j*nr]; gap = 0; for(i=nr-2 + j*nr; i>=0+j*nr; i--) { real_result[i] = real_x[i]; if(ISNA(real_result[i]) || ISNAN(real_result[i])) { if(limit > gap) real_result[i] = real_result[i+1]; gap++; } else { if((int)gap > (int)maxgap) { for(ii = i+1; ii < i+gap+1; ii++) { real_result[ii] = NA_REAL; } } gap=0; } } if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */ for(ii = i+1; ii < i+gap+1; ii++) { real_result[ii] = NA_REAL; } } } } break; case STRSXP: if(!LOGICAL(fromLast)[0]) { /* fromLast=FALSE */ for(j=0; j < nc; j++) { /* copy leading NAs */ _first = firstNonNACol(x, j); if (_first == nr + j*nr) _first--; for(i=0+j*nr; i < (_first+1); i++) { SET_STRING_ELT(result, i, STRING_ELT(x, i)); } /* result[_first] now has first value fromLast=FALSE */ gap = 0; for(i=_first+1; i gap) SET_STRING_ELT(result, i, STRING_ELT(result, i-1)); gap++; } else { if((int)gap > (int)maxgap) { for(ii = i-1; ii > i-gap-1; ii--) { SET_STRING_ELT(result, ii, NA_STRING); } } gap=0; } } if((int)gap > (int)maxgap) { /* check that we don't have excessive trailing gap */ for(ii = i-1; ii > i-gap-1; ii--) { SET_STRING_ELT(result, ii, NA_STRING); } } } } else { /* fromLast=TRUE */ for(j=0; j < nc; j++) { SET_STRING_ELT(result, nr-1+j*nr, STRING_ELT(x, nr-1+j*nr)); gap = 0; for(i=nr-2 + j*nr; i>=0+j*nr; i--) { SET_STRING_ELT(result, i, STRING_ELT(x, i)); if(STRING_ELT(result, i) == NA_STRING) { if(limit > gap) SET_STRING_ELT(result, i, STRING_ELT(result, i+1)); gap++; } else { if((int)gap > (int)maxgap) { for(ii = i+1; ii < i+gap+1; ii++) { SET_STRING_ELT(result, ii, NA_STRING); } } gap=0; } } if((int)gap > (int)maxgap) { /* check that we don't have leading trailing gap */ for(ii = i+1; ii < i+gap+1; ii++) { SET_STRING_ELT(result, ii, NA_STRING); } } } } break; default: error("unsupported type"); break; } if(isXts(x)) { setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol)); setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol)); copy_xtsCoreAttributes(x, result); copy_xtsAttributes(x, result); } UNPROTECT(P); return(result); } SEXP na_omit_xts (SEXP x) { SEXP na_index, not_na_index, col_index, result; int i, j, ij, nr, nc; int not_NA, NA; nr = nrows(x); nc = ncols(x); not_NA = nr; int *int_x=NULL, *int_na_index=NULL, *int_not_na_index=NULL; double *real_x=NULL; switch(TYPEOF(x)) { case LGLSXP: for(i=0; i. */ #include #include #include SEXP add_class (SEXP x, SEXP class) { if(MAYBE_SHARED(x)) x = duplicate(x); setAttrib(x, R_ClassSymbol, class); return(x); } xts/src/binsearch.c0000644000176200001440000001352513564762102013775 0ustar liggesusers/* # 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 . */ #include #include #include /* Binary search range to find interval written by Corwin Joy, with * contributions by Joshua Ulrich */ struct keyvec { double *dvec; double dkey; int *ivec; int ikey; }; /* Predicate function definition and functions to determine which of the * two groups contains the value being searched for. Note that they're all * 'static inline' to hopefully help with the compiler optimizations. */ typedef int (*bound_comparer)(const struct keyvec, const int); static inline int cmp_dbl_upper(const struct keyvec kv, const int i) { const double cv = kv.dvec[i]; const double ck = kv.dkey; return cv > ck; } static inline int cmp_dbl_lower(const struct keyvec kv, const int i) { const double cv = kv.dvec[i]; const double ck = kv.dkey; return cv >= ck; } static inline int cmp_int_upper(const struct keyvec kv, const int i) { const int cv = kv.ivec[i]; const int ck = kv.ikey; return cv > ck; } static inline int cmp_int_lower(const struct keyvec kv, const int i) { const int cv = kv.ivec[i]; const int ck = kv.ikey; return cv >= ck; } /* Binary search function */ SEXP binsearch(SEXP key, SEXP vec, SEXP start) { if (!isLogical(start)) { error("start must be specified as true or false"); } if (length(vec) < 1 || length(key) < 1) { return ScalarInteger(NA_INTEGER); } int use_start = LOGICAL(start)[0]; bound_comparer cmp_func = NULL; struct keyvec data; switch (TYPEOF(vec)) { case REALSXP: data.dkey = REAL(key)[0]; data.dvec = REAL(vec); cmp_func = (use_start) ? cmp_dbl_lower : cmp_dbl_upper; if (!R_finite(data.dkey)) { return ScalarInteger(NA_INTEGER); } break; case INTSXP: data.ikey = INTEGER(key)[0]; data.ivec = INTEGER(vec); cmp_func = (use_start) ? cmp_int_lower : cmp_int_upper; if (NA_INTEGER == data.ikey) { return ScalarInteger(NA_INTEGER); } break; default: error("unsupported type"); } int mid; int lo = 0; int hi = length(vec) - 1; while (lo < hi) { mid = lo + (hi - lo) / 2; if (cmp_func(data, mid)) { hi = mid; } else { lo = mid + 1; } } /* 'lo' contains the smallest index where cmp_func() is true, but we need * to handle edge cases where 'lo' is at the max/min end of the vector. */ if (use_start) { /* cmp_func() := vector[index] >= key when start == true, and we need * to return the smallest index subject to vector[index] >= key. */ if (!cmp_func(data, length(vec)-1)) { /* entire vector < key */ return ScalarInteger(NA_INTEGER); } } else { /* cmp_func() := vector[index] > key when start == false, and we need * to return the largest index subject to vector[index] <= key. */ if (cmp_func(data, lo)) { /* previous index value must satisfy vector[index] <= key, unless * current index value is zero. */ lo--; if (lo < 0) { /* entire vector > key */ return ScalarInteger(NA_INTEGER); } } } /* Convert from 0-based index to 1-based index */ lo++; return ScalarInteger(lo); } SEXP fill_window_dups_rev(SEXP _x, SEXP _index) { /* Translate user index (_x) to xts index (_index). '_x' contains the * upper bound of the location of the user index in the xts index. * This is necessary to handle duplicate dates in the xts index. */ int n_x = length(_x); int *x = INTEGER(_x); if (length(_index) < 1) { return allocVector(INTSXP, 0); } PROTECT_INDEX px; SEXP _out; PROTECT_WITH_INDEX(_out = allocVector(INTSXP, length(_index)), &px); int *out = INTEGER(_out); int i, xi, j, k = 0, n_out = length(_out); switch (TYPEOF(_index)) { case REALSXP: { double *index = REAL(_index); /* Loop over locations in _x in reverse order */ for (i = n_x; i > 0; i--) { xi = x[i-1]; j = xi; do { /* Check if we need to lengthen output due to duplicates */ if (k == n_out) { REPROTECT(_out = xlengthgets(_out, k+2*(i+1)), px); out = INTEGER(_out); n_out = length(_out); } out[k++] = j--; } while (j > 0 && index[xi-1] == index[j-1]); } } break; case INTSXP: { int *index = INTEGER(_index); /* Loop over locations in _x in reverse order */ for (i = n_x; i > 0; i--) { xi = x[i-1]; j = xi; do { /* Check if we need to lengthen output due to duplicates */ if (k == n_out) { REPROTECT(_out = xlengthgets(_out, k+2*(i+1)), px); out = INTEGER(_out); n_out = length(_out); } out[k++] = j--; } while (j > 0 && index[xi-1] == index[j-1]); } } break; default: error("unsupported index type"); } /* truncate so length(_out) = k * NB: output is in reverse order! */ REPROTECT(_out = xlengthgets(_out, k), px); UNPROTECT(1); return _out; } xts/src/rbind.c0000644000176200001440000004517213564762102013140 0ustar liggesusers/* # 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 . */ #include #include #include #include "xts.h" SEXP rbind_append(SEXP, SEXP); //SEXP do_rbind_xts (SEXP x, SEXP y, SEXP env) {{{ SEXP do_rbind_xts (SEXP x, SEXP y, SEXP dup) { int nrx, ncx, nry, ncy, truelen, len; int no_duplicate = LOGICAL(dup)[0]; int i, j, ij, ij_x, ij_y, xp=1, yp=1, add_y=0; int P=0; // PROTECT counter int mode; SEXP result, xindex, yindex, newindex; int *int_result=NULL, *int_x=NULL, *int_y=NULL; int *int_newindex=NULL, *int_xindex=NULL, *int_yindex=NULL; double *real_result=NULL, *real_x=NULL, *real_y=NULL; double *real_newindex=NULL, *real_xindex=NULL, *real_yindex=NULL; nrx = nrows(x); ncx = ncols(x); nry = nrows(y); ncy = ncols(y); truelen = len = nrx + nry; if( isNull(x) || isNull(y) ) { /* Handle NULL values by returning non-null object */ if(!isNull(x)) return x; return y; } if( !isXts(x) ) { PROTECT( x = tryXts(x) ); P++; } if( !isXts(y) ) { PROTECT( y = tryXts(y) ); P++; } /* need to convert different types of x and y if needed */ if( TYPEOF(x) != TYPEOF(y) ) { warning("mismatched types: converting objects to numeric"); // FIXME not working!!!???? PROTECT(x = coerceVector(x, REALSXP)); P++; PROTECT(y = coerceVector(y, REALSXP)); P++; } mode = TYPEOF(x); if(ncx != ncy) error("data must have same number of columns to bind by row"); PROTECT(xindex = getAttrib(x, xts_IndexSymbol)); P++; PROTECT(yindex = getAttrib(y, xts_IndexSymbol)); P++; if( TYPEOF(xindex) != TYPEOF(yindex) ) { PROTECT(xindex = coerceVector(xindex, REALSXP)); P++; PROTECT(yindex = coerceVector(yindex, REALSXP)); P++; } #ifdef RBIND_APPEND if(TYPEOF(xindex)==REALSXP) { if(REAL(xindex)[length(xindex)-1] < REAL(yindex)[0]) { UNPROTECT(P); return rbind_append(x,y); } } else if(TYPEOF(xindex)==INTSXP) { if(INTEGER(xindex)[length(xindex)-1] < INTEGER(yindex)[0]) { UNPROTECT(P); return rbind_append(x,y); } } #endif if(nrx != length(xindex) || nry != length(yindex)) error("zero-length vectors with non-zero-length index are not allowed"); PROTECT(newindex = allocVector(TYPEOF(xindex), len)); P++; PROTECT(result = allocVector(TYPEOF(x), len * ncx)); P++; switch( TYPEOF(x) ) { case INTSXP: int_x = INTEGER(x); int_y = INTEGER(y); int_result = INTEGER(result); break; case REALSXP: real_x = REAL(x); real_y = REAL(y); real_result = REAL(result); break; default: break; } /* if( TYPEOF(xindex) == REALSXP ) { if(REAL(xindex)[nrx-1] < REAL(yindex)[0]) { memcpy(REAL(newindex), REAL(xindex), sizeof(double) * nrx); memcpy(REAL(newindex)+nrx, REAL(yindex), sizeof(double) * nry); switch(TYPEOF(x)) { case INTSXP: memcpy(INTEGER(result), INTEGER(x), sizeof(int) * (nrx*ncx)); memcpy(INTEGER(result)+(nrx*ncx), INTEGER(y), sizeof(int) * (nry*ncy)); break; case REALSXP: memcpy(REAL(result), REAL(x), sizeof(double) * (nrx*ncx)); memcpy(REAL(result)+(nrx*ncx), REAL(y), sizeof(double) * (nry*ncy)); break; default: break; } UNPROTECT(P); return(result); } } else { } */ /* The main body of code to follow branches based on the type of index, removing the need to test at each position. */ if( TYPEOF(xindex) == REALSXP ) { real_newindex = REAL(newindex); real_xindex = REAL(xindex); real_yindex = REAL(yindex); for( i = 0; i < len; i++ ) { if( i >= truelen ) { break; } else if( xp > nrx ) { real_newindex[ i ] = real_yindex[ yp-1 ]; for(j = 0; j < ncx; j++) { ij = i + j * len; ij_y = (yp-1) + j * nry; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ]; break; case INTSXP: int_result[ ij ] = int_y[ ij_y ]; break; case REALSXP: real_result[ ij ] = real_y[ ij_y ]; break; case CPLXSXP: COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y)); break; default: break; } } yp++; } else if( yp > nry ) { real_newindex[ i ] = real_xindex[ xp-1 ]; for(j = 0; j < ncx; j++) { ij = i + j * len; ij_x = (xp-1) + j * nrx; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ]; break; case INTSXP: int_result[ ij ] = int_x[ ij_x ]; break; case REALSXP: real_result[ ij ] = real_x[ ij_x ]; break; case CPLXSXP: COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x)); break; default: break; } } xp++; } else if( real_xindex[ xp-1 ] == real_yindex[ yp-1 ] ) { if( xp < nrx && real_xindex[ xp-1 ] < real_xindex[ xp ] ) add_y = 1; /* add y values only if next xindex is new */ if(no_duplicate) { add_y = 0; truelen--; } real_newindex[ i ] = real_xindex[ xp-1 ]; if(add_y) real_newindex[ i+ 1 ] = real_yindex[ yp-1 ]; for(j = 0; j < ncx; j++) { ij = i + j * len; ij_x = (xp-1) + j * nrx; ij_y = (yp-1) + j * nry; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ]; if(add_y) LOGICAL(result)[ ij+1 ] = LOGICAL(y)[ ij_y ]; break; case INTSXP: int_result[ ij ] = int_x[ ij_x ]; if(add_y) int_result[ ij+1 ] = int_y[ ij_y ]; break; case REALSXP: real_result[ ij ] = real_x[ ij_x ]; if(add_y) real_result[ ij+1 ] = real_y[ ij_y ]; break; case CPLXSXP: COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ]; if(add_y) COMPLEX(result)[ ij+1 ] = COMPLEX(y)[ ij_y ]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x)); if(add_y) SET_STRING_ELT(result, ij+1, STRING_ELT(y, ij_y)); break; default: break; } } xp++; if(no_duplicate || add_y) { yp++; if(!no_duplicate) i++; // need to increase i as we now have filled in 2 values add_y = 0; } } else if( real_xindex[ xp-1 ] < real_yindex[ yp-1 ] ) { real_newindex[ i ] = real_xindex[ xp-1 ]; for(j = 0; j < ncx; j++) { ij = i + j * len; ij_x = (xp-1) + j * nrx; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ]; break; case INTSXP: int_result[ ij ] = int_x[ ij_x ]; break; case REALSXP: real_result[ ij ] = real_x[ ij_x ]; break; case CPLXSXP: COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x)); break; default: break; } } xp++; } else if( real_xindex[ xp-1 ] > real_yindex[ yp-1 ] ) { real_newindex[ i ] = real_yindex[ yp-1 ]; for(j = 0; j < ncx; j++) { ij = i + j * len; ij_y = (yp-1) + j * nry; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ]; break; case INTSXP: int_result[ ij ] = int_y[ ij_y ]; break; case REALSXP: real_result[ ij ] = real_y[ ij_y ]; break; case CPLXSXP: COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y)); break; default: break; } } yp++; } } } else if( TYPEOF(xindex) == INTSXP ) { int_newindex = INTEGER(newindex); int_xindex = INTEGER(xindex); int_yindex = INTEGER(yindex); for(i = 0; i < len; i++) { /*Rprintf("xp:%i, yp:%i, i:%i\n",xp,yp,i);*/ if( i >= truelen ) { break; } else if( xp > nrx ) { int_newindex[ i ] = int_yindex[ yp-1 ]; for(j = 0; j < ncx; j++) { ij = i + j * len; ij_y = (yp-1) + j * nry; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ]; break; case INTSXP: int_result[ ij ] = int_y[ ij_y ]; break; case REALSXP: real_result[ ij ] = real_y[ ij_y ]; break; case CPLXSXP: COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y)); break; default: break; } } yp++; } else if( yp > nry ) { int_newindex[ i ] = int_xindex[ xp-1 ]; for(j = 0; j < ncx; j++) { ij = i + j * len; ij_x = (xp-1) + j * nrx; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ]; break; case INTSXP: int_result[ ij ] = int_x[ ij_x ]; break; case REALSXP: real_result[ ij ] = real_x[ ij_x ]; break; case CPLXSXP: COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x)); break; default: break; } } xp++; } else if( int_xindex[ xp-1 ] == int_yindex[ yp-1 ] ) { if( xp < nrx && int_xindex[ xp-1 ] < int_xindex[ xp ] ) add_y = 1; if(no_duplicate) { add_y = 0; truelen--; } int_newindex[ i ] = int_xindex[ xp-1 ]; if(add_y) int_newindex[ i+1 ] = int_yindex[ yp-1 ]; for(j = 0; j < ncx; j++) { ij = i + j * len; ij_x = (xp-1) + j * nrx; ij_y = (yp-1) + j * nry; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ]; if(add_y) LOGICAL(result)[ ij+1 ] = LOGICAL(y)[ ij_y ]; break; case INTSXP: int_result[ ij ] = int_x[ ij_x ]; if(add_y) int_result[ ij+1 ] = int_y[ ij_y ]; break; case REALSXP: real_result[ ij ] = real_x[ ij_x ]; if(add_y) real_result[ ij+1 ] = real_y[ ij_y ]; break; case CPLXSXP: COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ]; if(add_y) COMPLEX(result)[ ij+1 ] = COMPLEX(y)[ ij_y ]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x)); if(add_y) SET_STRING_ELT(result, ij+1, STRING_ELT(y, ij_y)); break; default: break; } } xp++; if(no_duplicate || add_y) { yp++; if(!no_duplicate) i++; // need to increase i as we now have filled in 2 values add_y = 0; } } else if( int_xindex[ xp-1 ] < int_yindex[ yp-1 ] ) { int_newindex[ i ] = int_xindex[ xp-1 ]; for(j = 0; j < ncx; j++) { ij = i + j * len; ij_x = (xp-1) + j * nrx; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij ] = LOGICAL(x)[ ij_x ]; break; case INTSXP: int_result[ ij ] = int_x[ ij_x ]; break; case REALSXP: real_result[ ij ] = real_x[ ij_x ]; break; case CPLXSXP: COMPLEX(result)[ ij ] = COMPLEX(x)[ ij_x ]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(x, ij_x)); break; default: break; } } xp++; } else if( int_xindex[ xp-1 ] > int_yindex[ yp-1 ] ) { int_newindex[ i ] = int_yindex[ yp-1 ]; for(j = 0; j < ncx; j++) { ij = i + j * len; ij_y = (yp-1) + j * nry; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij ] = LOGICAL(y)[ ij_y ]; break; case INTSXP: int_result[ ij ] = int_y[ ij_y ]; break; case REALSXP: real_result[ ij ] = real_y[ ij_y ]; break; case CPLXSXP: COMPLEX(result)[ ij ] = COMPLEX(y)[ ij_y ]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(y, ij_y)); break; default: break; } } yp++; }} } if(truelen != len) { PROTECT(result = lengthgets(result, truelen * ncx)); P++; /* reset length */ } setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol)); SEXP dim; PROTECT(dim = allocVector(INTSXP, 2)); INTEGER(dim)[0] = truelen; INTEGER(dim)[1] = INTEGER(getAttrib(x, R_DimSymbol))[1]; UNPROTECT(1); setAttrib(result, R_DimSymbol, dim); setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); if(truelen != len) { PROTECT(newindex = lengthgets(newindex, truelen)); P++; } copyMostAttrib(xindex, newindex); setAttrib(result, xts_IndexSymbol, newindex); setAttrib(result, xts_ClassSymbol, getAttrib(x, xts_ClassSymbol)); copy_xtsAttributes(x, result); UNPROTECT(P); return result; } //}}} // SEXP rbindXts ( .External("rbindXts", ...) ) {{{ SEXP rbindXts (SEXP args) { SEXP _x; SEXP dup; int P=0; PROTECT_INDEX ipx; args = CDR(args); // 'rbindXts' call name PROTECT(dup = CAR(args)); P++; args = CDR(args); PROTECT(_x = CAR(args)); P++; args = CDR(args); if(args == R_NilValue) { UNPROTECT(P); return(_x); } PROTECT_WITH_INDEX(_x = do_rbind_xts(_x, CAR(args), dup), &ipx); P++; args = CDR(args); while(args != R_NilValue) { REPROTECT(_x = do_rbind_xts(_x, CAR(args), dup), ipx); args = CDR(args); } if(P > 0) UNPROTECT(P); return _x; } //}}} SEXP rbind_append (SEXP x, SEXP y) { /* Provide fast row binding of xts objects if the left-hand object (binding target) has a last index value less than the right-hand object (object to bind). This is an optimization to allow for real-time updating of objects without having to do much more than a memcpy of the two in coordinated fashion */ /*Rprintf("rbind_append called\n");*/ SEXP result; int nrs_x, nrs_y, ncs_x, ncs_y, nr; int i; ncs_x = ncols(x); ncs_y = ncols(y); nrs_x = nrows(x); nrs_y = nrows(y); if(ncs_x != ncs_y) error("objects must have the same number of columns"); /* FIXME */ PROTECT(result = allocVector(TYPEOF(x), (nrs_x + nrs_y) * ncs_x)); nr = nrs_x + nrs_y; switch(TYPEOF(x)) { case REALSXP: for(i=0; i< ncs_x; i++) { memcpy(&(REAL(result)[i*nr]), &(REAL(x)[i*nrs_x]), nrs_x*sizeof(double)); memcpy(&(REAL(result)[i*nr + nrs_x]), &(REAL(y)[i*nrs_y]), nrs_y*sizeof(double)); } break; case INTSXP: for(i=0; i< ncs_x; i++) { memcpy(&(INTEGER(result)[i*nr]), &(INTEGER(x)[i*nrs_x]), nrs_x*sizeof(int)); memcpy(&(INTEGER(result)[i*nr + nrs_x]), &(INTEGER(y)[i*nrs_y]), nrs_y*sizeof(int)); } break; case LGLSXP: for(i=0; i< ncs_x; i++) { memcpy(&(LOGICAL(result)[i*nr]), &(LOGICAL(x)[i*nrs_x]), nrs_x*sizeof(int)); memcpy(&(LOGICAL(result)[i*nr + nrs_x]), &(LOGICAL(y)[i*nrs_y]), nrs_y*sizeof(int)); } break; case CPLXSXP: for(i=0; i< ncs_x; i++) { memcpy(&(COMPLEX(result)[i*nr]), &(COMPLEX(x)[i*nrs_x]), nrs_x*sizeof(Rcomplex)); memcpy(&(COMPLEX(result)[i*nr + nrs_x]), &(COMPLEX(y)[i*nrs_y]), nrs_y*sizeof(Rcomplex)); } break; case RAWSXP: for(i=0; i< ncs_x; i++) { memcpy(&(RAW(result)[i*nr]), &(RAW(x)[i*nrs_x]), nrs_x*sizeof(Rbyte)); memcpy(&(RAW(result)[i*nr + nrs_x]), &(RAW(y)[i*nrs_y]), nrs_y*sizeof(Rbyte)); } break; case STRSXP: /* this requires an explicit loop like rbind.c and needs to be left with rbind.c */ break; default: error("unsupported type"); } copyAttributes(x, result); SEXP index, xindex, yindex; xindex = getAttrib(x, xts_IndexSymbol); yindex = getAttrib(y, xts_IndexSymbol); int INDEXTYPE = TYPEOF(xindex); if(INDEXTYPE != NILSXP) { PROTECT(index = allocVector(INDEXTYPE, nr)); if(INDEXTYPE==REALSXP) { memcpy(REAL(index), REAL(xindex), nrs_x * sizeof(double)); memcpy(&(REAL(index)[nrs_x]), REAL(yindex), nrs_y * sizeof(double)); } else if(INDEXTYPE==INTSXP) { memcpy(INTEGER(index), INTEGER(xindex), nrs_x * sizeof(int)); memcpy(&(INTEGER(index)[nrs_x]), INTEGER(yindex), nrs_y * sizeof(int)); } copyMostAttrib(xindex, index); setAttrib(result, xts_IndexSymbol, index); UNPROTECT(1); } SEXP dim; PROTECT(dim = allocVector(INTSXP, 2)); INTEGER(dim)[0] = nr; INTEGER(dim)[1] = ncs_x; /* should be the same */ setAttrib(result, R_DimSymbol, dim); UNPROTECT(1); setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); /* SEXP dimnames, currentnames, newnames; PROTECT(dimnames = allocVector(VECSXP, 2)); PROTECT(newnames = allocVector(STRSXP, length(j))); currentnames = getAttrib(x, R_DimNamesSymbol); if(!isNull(currentnames)) { SET_VECTOR_ELT(dimnames, 0, R_NilValue); for(i=0; i. */ #include #include #include "xts.h" SEXP coredata (SEXP x, SEXP copyAttr) { /* copyAttr is a LGLSXP flag to indicate whether all attributes are to be left intact. This provides compatability with xts, by stripping all attributes if desired, without the overhead or adding then removing */ SEXP result; int i, j, ncs, nrs; int P=0; PROTECT(result = allocVector(TYPEOF(x), length(x))); P++; switch( TYPEOF(x)) { case REALSXP: memcpy(REAL(result), REAL(x), length(result) * sizeof(double)); break; case INTSXP: memcpy(INTEGER(result), INTEGER(x), length(result) * sizeof(int)); break; case LGLSXP: memcpy(LOGICAL(result), LOGICAL(x), length(result) * sizeof(int)); break; case CPLXSXP: memcpy(COMPLEX(result), COMPLEX(x), length(result) * sizeof(Rcomplex)); break; case STRSXP: ncs = ncols(x); nrs = nrows(x); for(j=0; j< ncs; j++) for(i=0; i< nrs; i++) SET_STRING_ELT(result, i+j*nrs, STRING_ELT(x, i+j*nrs)); break; case RAWSXP: memcpy(RAW(result), RAW(x), length(result) * sizeof(unsigned char)); break; default: error("currently unsupported data type"); break; } if( !isNull(getAttrib(x, R_DimSymbol))) { setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol)); if( !isNull(getAttrib(x, R_DimNamesSymbol)) ) { setAttrib(result, R_DimNamesSymbol, getAttrib(x,R_DimNamesSymbol)); } } else { setAttrib(result, R_NamesSymbol, getAttrib(x, R_NamesSymbol)); } if( asLogical(copyAttr)) { copyMostAttrib(x,result); setAttrib(result, R_ClassSymbol, getAttrib(x, install("oclass"))); } setAttrib(result, xts_IndexSymbol, R_NilValue); setAttrib(result, install("oclass"), R_NilValue); setAttrib(result, install("frequency"), R_NilValue); UNPROTECT(P); return result; } SEXP coredata_xts(SEXP x) { return zoo_coredata(x, ScalarLogical(0)); } xts/src/startofyear.c0000644000176200001440000000420613564762102014376 0ustar liggesusers/* # 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 . */ void do_startofyear (int *from, int *to, int *fromto, int *origin) { // do_startofyear {{{ int i; int nyear[1] = { (to[0] - from[0] + 1) }; int leap[nyear[0]]; // generate sequence of dates to work with fromto[0] = from[0]; for(i=1; i < nyear[0]; i++) { fromto[i] = fromto[i-1] + 1; } for(i = 0; i < nyear[0]; i++) { leap[ i ] = ( (fromto[ i ] % 4 == 0 && fromto[ i ] % 100 != 0) || fromto[ i ] % 400 == 0) ? 1 : 0; } for(i=0; i < nyear[0]; i++) { if(leap[i] == 1) { // a leapyear (366 days) fromto[i] = 366; } else { // a non-leapyear (365 days) fromto[i] = 365; } } /* fromto now has proper number of days per year now calculate the cumulative sum back from origin (negative) and from origin (positive) */ int days_before_origin = origin[0] - from[0]; //int days_after_origin = nyear[0] - days_before_origin - 1; //why is this here? int tmp=0; for(i = days_before_origin; i < nyear[0]; i++) { tmp += fromto[i]; fromto[i] = tmp; } tmp = 0; for(i = days_before_origin-1; i >= 0; i--) { tmp -= fromto[i]; fromto[i] = tmp; } /* now insert a 0 at the origin, by going backwards */ for(i = nyear[0] - 1; i > days_before_origin; i--) fromto[ i ] = fromto[ i-1 ]; fromto[ days_before_origin ] = 0; } //}}} xts/src/tryXts.c0000644000176200001440000000252312530101636013337 0ustar liggesusers/* # 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 . */ #include #include #include "xts.h" SEXP tryXts (SEXP x) { if( !isXts(x) ) { SEXP s, t, result; PROTECT(s = t = allocList(2)); SET_TYPEOF(s, LANGSXP); SETCAR(t, install("try.xts")); t = CDR(t); SETCAR(t, x); t=CDR(t); PROTECT(result = eval(s, R_GlobalEnv)); if( !isXts(result) ) { UNPROTECT(2); error("rbind.xts requires xtsible data"); } UNPROTECT(2); return result; } return x; } /* SEXP try_xts (SEXP x) { SEXP y; PROTECT(y = tryXts(x)); UNPROTECT(1); return y; } */ xts/src/endpoints.c0000644000176200001440000001031713564762102014036 0ustar liggesusers/* # 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 . */ #include #include #include #include SEXP endpoints (SEXP _x, SEXP _on, SEXP _k, SEXP _addlast /* TRUE */) { /* efficient implementation of: c(0,which(diff(_x%/%on%/%k+1) != 0),NROW(_x)) */ int *int_index = NULL; double *real_index = NULL; int i=1,j=1, nr, P=0; int int_tmp[2]; int64_t int64_tmp[2]; /* shouldn't force to INTSXP, as this now excludes microsecond and millisecond calculations FIXME */ int on = INTEGER(coerceVector(_on,INTSXP))[0]; int k = INTEGER(coerceVector(_k,INTSXP))[0]; nr = nrows(_x); /* ensure k > 0 (bug #4920) */ if(k <= 0) error("'k' must be > 0"); /* endpoints objects. max nr+2 ( c(0,ep,nr) ) */ SEXP _ep = PROTECT(allocVector(INTSXP,nr+2)); P++; int *ep = INTEGER(_ep); /*switch(TYPEOF(getAttrib(_x, install("index")))) {*/ switch(TYPEOF(_x)) { case INTSXP: /* start i at second elem */ /*int_index = INTEGER(getAttrib(_x, install("index")));*/ int_index = INTEGER(_x); ep[0] = 0; /* special handling if index values < 1970-01-01 00:00:00 UTC */ if(int_index[0] < 0) { int_tmp[1] = (int_index[0] + 1) / on / k; for(i=1,j=1; i. */ #include #include SEXP any_negative (SEXP i_) { int i; int len = length(i_); int *int_i=NULL; double *real_i=NULL; if(TYPEOF(i_)==INTSXP) { int_i = INTEGER(i_); for(i=0; i= 0) continue; return ScalarLogical(1); } } else if(TYPEOF(i_)==REALSXP) { real_i = REAL(i_); for(i=0; i= 0) continue; return ScalarLogical(1); } } return ScalarLogical(0); } xts/src/totalcols.c0000644000176200001440000000245213564762102014040 0ustar liggesusers/* # 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 . */ #include #include #include #include "xts.h" SEXP number_of_cols (SEXP args) { SEXP tcols; int P=0; args = CDR(args); // calling function name PROTECT(tcols = allocVector(INTSXP, length(args))); P++; int i=0; for(;args != R_NilValue; i++, args=CDR(args)) { /* if( TAG(args) == R_NilValue ) { */ if( length(CAR(args)) > 0) { INTEGER(tcols)[i] = ncols(CAR(args)); } else INTEGER(tcols)[i] = (int)0; /* } */ } UNPROTECT(P); return tcols; } xts/src/period_apply.c0000644000176200001440000000406113564762102014521 0ustar liggesusers/* # xts: eXtensible time-series # # Copyright (C) 2008 Jeffrey A. Ryan (FORTRAN implementation) # Copyright (C) 2018 Joshua M. Ulrich (C implementation) # # 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 . */ #include #include "xts.h" SEXP xts_period_apply(SEXP _data, SEXP _index, SEXP _function, SEXP _env) { if (!isInteger(_index)) { error("index must be integer"); } int i; R_xlen_t n = xlength(_index); SEXP _result = PROTECT(allocVector(VECSXP, n)); SEXP _j = PROTECT(allocVector(INTSXP, ncols(_data))); SEXP _drop = PROTECT(ScalarLogical(0)); int *index = INTEGER(_index); for (i = 0; i < ncols(_data); i++) INTEGER(_j)[i] = i + 1; SEXP _idx0 = PROTECT(ScalarInteger(0)); SEXP _idx1 = PROTECT(ScalarInteger(0)); int *idx0 = INTEGER(_idx0); int *idx1 = INTEGER(_idx1); /* reprotect the subset object */ SEXP _xsubset; PROTECT_INDEX px; PROTECT_WITH_INDEX(_xsubset = R_NilValue, &px); /* subset object name */ SEXP _subsym = install("_.*crazy*._.*name*._"); defineVar(_subsym, _xsubset, _env); /* function call on subset */ SEXP _subcall = PROTECT(lang3(_function, _subsym, R_DotsSymbol)); int N = n - 1; for (i = 0; i < N; i++) { idx0[0] = index[i] + 1; idx1[0] = index[i + 1]; REPROTECT(_xsubset = extract_col(_data, _j, _drop, _idx0, _idx1), px); defineVar(_subsym, _xsubset, _env); SET_VECTOR_ELT(_result, i, eval(_subcall, _env)); } UNPROTECT(7); return _result; } xts/src/extract_col.c0000644000176200001440000001342213564762102014342 0ustar liggesusers/* # 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 . */ #include #include #include "xts.h" /* provide fast memcpy extraction by column major orientation for matrix objects. Should be as fast as extracting list elements or data.frame columns in R. ( update: it is much faster actually -jar ) One key difference is that we are also reattaching the index attribute to allow for the object to remain a zoo/xts object */ SEXP extract_col (SEXP x, SEXP j, SEXP drop, SEXP first_, SEXP last_) { SEXP result, index, new_index; int nrs, nrsx, i, ii, jj, first, last; nrsx = nrows(x); first = asInteger(first_)-1; last = asInteger(last_)-1; /* nrs = offset_end - offset_start - 1; */ nrs = last - first + 1; PROTECT(result = allocVector(TYPEOF(x), nrs * length(j))); switch(TYPEOF(x)) { case REALSXP: for(i=0; i. */ #include #include #include #include "xts.h" SEXP xts_make_names(SEXP colnames, SEXP env) { SEXP s, t, unique; PROTECT(s = t = allocList(3)); SET_TYPEOF(s, LANGSXP); SETCAR(t, install("make.names")); t = CDR(t); SETCAR(t, colnames); t = CDR(t); PROTECT(unique = allocVector(LGLSXP, 1)); LOGICAL(unique)[0] = 1; SETCAR(t, unique); SET_TAG(t, install("unique")); SEXP res = PROTECT(eval(s, env)); UNPROTECT(3); return(res); } /* This is a merge_join algorithm used to allow two xts objects to be merged as one along a common index efficiently and fast The code is branched for REAL and INTEGER indexed values which allows for efficient memory usage and minimal testing/coercion Copyright Jeffrey A. Ryan 2008 */ /* do_merge_xts {{{ */ SEXP do_merge_xts (SEXP x, SEXP y, SEXP all, SEXP fill, SEXP retclass, SEXP colnames, SEXP suffixes, SEXP retside, SEXP check_names, SEXP env, int coerce) { int nrx, ncx, nry, ncy, len; int left_join, right_join; int i = 0, j = 0, xp = 1, yp = 1; /* x and y positions in index */ int mode; int ij_original, ij_result; int p = 0; SEXP xindex, yindex, index, result, attr, len_xindex; SEXP s, t; int *int_result=NULL, *int_x=NULL, *int_y=NULL, int_fill=0; int *int_index=NULL, *int_xindex=NULL, *int_yindex=NULL; double *real_result=NULL, *real_x=NULL, *real_y=NULL; double *real_index=NULL, *real_xindex=NULL, *real_yindex=NULL; /* we do not check that 'x' is an xts object. Dispatch and mergeXts (should) make this unecessary. So we just get the index value This assumption seems to be invalid when dispatched from cbind.xts So we need to check that the objects are not NULL, or at least treat NULL objects as zero-width with an index that matches the non-null 2009/01/07: calling merge(NA,x) or merge(1,1,xts) causes a segfault; calling merge(1,x) causes the xts-info (none!) from the 1st arg to be used, resulting in a classless object. [fixed - jar] */ if( isNull(x) || isNull(y) ) { if(!isNull(x)) return(x); return(y); } PROTECT( xindex = getAttrib(x, xts_IndexSymbol) ); p++; /* convert to xts object if needed */ if( !isXts(y) ) { PROTECT(s = t = allocList(4)); p++; SET_TYPEOF(s, LANGSXP); SETCAR(t, install("try.xts")); t = CDR(t); SETCAR(t, y); t = CDR(t); PROTECT( len_xindex = allocVector(INTSXP, 1)); p++; INTEGER(len_xindex)[0] = length(xindex); SETCAR(t, len_xindex); SET_TAG(t, install("length.out")); t = CDR(t); SETCAR(t, install(".merge.xts.scalar")); SET_TAG(t, install("error")); PROTECT(y = eval(s, env)); p++; } /* end conversion process */ mode = TYPEOF(x); if( isXts(y) ) { PROTECT( yindex = getAttrib(y, xts_IndexSymbol) ); p++; } else { PROTECT( yindex = getAttrib(x, xts_IndexSymbol) ); p++; } if( TYPEOF(retside) != LGLSXP ) error("retside must be a logical value of TRUE or FALSE"); nrx = nrows(x); ncx = ncols(x); /* if object is zero-width */ if( LENGTH(x)==0 || INTEGER(retside)[0]==0 ) { nrx = nrows(xindex); ncx = 0; PROTECT(x = coerceVector(x, TYPEOF(y))); p++; } nry = nrows(y); ncy = ncols(y); /* if object is zero-width */ if( LENGTH(y)==0 || INTEGER(retside)[1]==0) { nry = nrows(yindex); ncy = 0; PROTECT(y = coerceVector(y, TYPEOF(x))); p++; } len = nrx + nry; /* at present we are failing the call if the indexing is of mixed type. This should probably instead simply coerce to REAL so as not to lose any information (at the expense of conversion cost and memory), and issue a warning. */ if( TYPEOF(xindex) != TYPEOF(yindex) ) { PROTECT(xindex = coerceVector(xindex, REALSXP)); p++; PROTECT(yindex = coerceVector(yindex, REALSXP)); p++; } if( TYPEOF(all) != LGLSXP ) error("all must be a logical value of TRUE or FALSE"); left_join = INTEGER(all)[ 0 ]; right_join = INTEGER(all)[ 1 ]; /* determine num_rows of final merged xts object this seems to only cost 1/1000 of a sec per 1e6 observations. Acceptable 'waste' given that now we can properly allocate space for our results We also check the index type and use the appropriate macros */ if( TYPEOF(xindex) == REALSXP ) { real_xindex = REAL(xindex); real_yindex = REAL(yindex); /* Check for illegal values before looping. Due to ordered index, * -Inf must be first, while NA, Inf, and NaN must be last. */ if (!R_FINITE(real_xindex[0]) || !R_FINITE(real_xindex[nrx-1]) || !R_FINITE(real_yindex[0]) || !R_FINITE(real_yindex[nry-1])) { error("'index' cannot contain 'NA', 'NaN', or '+/-Inf'"); } while( (xp + yp) <= (len + 1) ) { if( xp > nrx ) { yp++; if(right_join) i++; } else if( yp > nry ) { xp++; if(left_join) i++; } else if( real_xindex[ xp-1 ] == real_yindex[ yp-1 ] ) { /* INNER JOIN --- only result if all=FALSE */ yp++; xp++; i++; } else if( real_xindex[ xp-1 ] < real_yindex[ yp-1 ] ) { /* LEFT JOIN */ xp++; if(left_join) i++; } else if( real_xindex[ xp-1 ] > real_yindex[ yp-1 ] ) { /* RIGHT JOIN */ yp++; if(right_join) i++; } else error("Invalid index element comparison (should never happen)"); } } else if( TYPEOF(xindex) == INTSXP ) { int_xindex = INTEGER(xindex); int_yindex = INTEGER(yindex); /* Check for NA before looping; logical ops on NA may yield surprising * results. Note that the NA_integer_ will appear in the last value of * the index because of sorting at the R level, even though NA_INTEGER * equals INT_MIN at the C level. */ if (int_xindex[nrx-1] == NA_INTEGER || int_yindex[nry-1] == NA_INTEGER) { error("'index' cannot contain 'NA'"); } while( (xp + yp) <= (len + 1) ) { if( xp > nrx ) { yp++; if(right_join) i++; } else if( yp > nry ) { xp++; if(left_join) i++; } else if( int_xindex[ xp-1 ] == int_yindex[ yp-1 ] ) { yp++; xp++; i++; } else if( int_xindex[ xp-1 ] < int_yindex[ yp-1 ] ) { xp++; if(left_join) i++; } else if( int_xindex[ xp-1 ] > int_yindex[ yp-1 ] ) { yp++; if(right_join) i++; } else error("Invalid index element comparison (should never happen)"); } } if(i == 0) { /* if no rows match, return an empty xts object, similar in style to zoo */ PROTECT( result = allocVector(TYPEOF(x), 0) ); p++; PROTECT( index = allocVector(TYPEOF(xindex), 0) ); p++; SET_xtsIndex(result, index); if(LOGICAL(retclass)[0]) setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol)); UNPROTECT(p); return result; } int num_rows = i; xp = 1; yp = 1; PROTECT( index = allocVector(TYPEOF(xindex), num_rows) ); p++; /* coercion/matching of TYPE for x and y needs to be checked, either here or in the calling R code. I suspect here is more useful if other function can call the C code as well. If objects are not the same type, convert to REALSXP. */ if( coerce || TYPEOF(x) != TYPEOF(y) ) { PROTECT( x = coerceVector(x, REALSXP) ); p++; PROTECT( y = coerceVector(y, REALSXP) ); p++; } PROTECT( result = allocVector(TYPEOF(x), (ncx + ncy) * num_rows) ); p++; /* Ensure fill is the correct length and type */ if( length(fill) < 1 ) { PROTECT( fill = ScalarLogical(NA_LOGICAL) ); p++; } if( TYPEOF(fill) != TYPEOF(x) ) { PROTECT( fill = coerceVector(fill, TYPEOF(x)) ); p++; } mode = TYPEOF(x); /* use pointers instead of function calls */ switch(TYPEOF(x)) { case INTSXP: int_x = INTEGER(x); int_y = INTEGER(y); int_fill = INTEGER(fill)[0]; int_result = INTEGER(result); break; case REALSXP: real_x = REAL(x); real_y = REAL(y); /*real_fill = REAL(fill)[0];*/ real_result = REAL(result); break; default: break; } switch(TYPEOF(xindex)) { case INTSXP: int_index = INTEGER(index); break; case REALSXP: real_index = REAL(index); break; default: break; } /* There are two type of supported index types, each branched from here */ if( TYPEOF(xindex) == REALSXP ) { /* REAL INDEXING */ for(i = 0; i < num_rows; i++) { /* If we are past the last row in x, assign NA to merged data and copy the y column values to the second side of result */ if( xp > nrx ) { if(right_join) { real_index[ i ] = real_yindex[ yp-1 ]; for(j = 0; j < ncx; j++) { /* x-values */ ij_result = i + j * num_rows; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(fill)[ 0 ]; break; case INTSXP: /*INTEGER(result)[ ij_result ] = INTEGER(fill)[ 0 ];*/ int_result[ ij_result ] = int_fill; break; case REALSXP: REAL(result)[ ij_result ] = REAL(fill)[ 0 ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ].r = REAL(fill)[ 0 ]; COMPLEX(result)[ ij_result ].i = REAL(fill)[ 0 ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(fill, 0)); break; default: error("unsupported data type"); break; } } for(j = 0; j < ncy; j++) { /* y-values */ ij_result = i + (j+ncx) * num_rows; ij_original = (yp-1) + j * nry; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(y)[ ij_original ]; break; case INTSXP: int_result[ ij_result ] = int_y[ ij_original ]; break; case REALSXP: real_result[ ij_result ] = real_y[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(y)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(y, ij_original)); break; default: error("unsupported data type"); break; } } } yp++; if(!right_join) i--; /* if all=FALSE, we must decrement i for each non-match */ } else /* past the last row of y */ if( yp > nry ) { if(left_join) { /* record new index value */ real_index[ i ] = real_xindex[ xp-1 ]; /* copy values from x and y to result */ for(j = 0; j < ncx; j++) { /* x-values */ ij_result = i + j * num_rows; ij_original = (xp-1) + j * nrx; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(x)[ ij_original ]; break; case INTSXP: int_result[ ij_result ] = int_x[ ij_original ]; break; case REALSXP: real_result[ ij_result ] = real_x[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(x)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(x, ij_original)); break; default: error("unsupported data type"); break; } } /* we are out of y-values, so fill merged result with NAs */ for(j = 0; j < ncy; j++) { /* y-values */ ij_result = i + (j+ncx) * num_rows; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(fill)[ 0 ]; break; case INTSXP: /*INTEGER(result)[ ij_result ] = INTEGER(fill)[ 0 ];*/ int_result[ ij_result ] = int_fill; break; case REALSXP: REAL(result)[ ij_result ] = REAL(fill)[ 0 ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ].r = REAL(fill)[ 0 ]; COMPLEX(result)[ ij_result ].i = REAL(fill)[ 0 ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(fill, 0)); break; default: error("unsupported data type"); break; } } } xp++; if(!left_join) i--; } else /* matching index values copy all column values from x and y to results */ if( real_xindex[ xp-1 ] == real_yindex[ yp-1 ] ) { real_index[ i ] = real_xindex[ xp-1 ]; /* copy x-values to result */ for(j = 0; j < ncx; j++) { /* x-values */ ij_result = i + j * num_rows; ij_original = (xp-1) + j * nrx; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(x)[ ij_original ]; break; case INTSXP: int_result[ ij_result ] = int_x[ ij_original ]; break; case REALSXP: real_result[ ij_result ] = real_x[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(x)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(x, ij_original)); break; default: error("unsupported data type"); break; } } /* copy y-values to result */ for(j = 0; j < ncy; j++) { /* y-values */ ij_result = i + (j+ncx) * num_rows; ij_original = (yp-1) + j * nry; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(y)[ ij_original ]; break; case INTSXP: int_result[ ij_result ] = int_y[ ij_original ]; break; case REALSXP: real_result[ ij_result ] = real_y[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(y)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(y, ij_original)); break; default: error("unsupported data type"); break; } } xp++; yp++; } else if( real_xindex[ xp-1 ] < real_yindex[ yp-1 ] ) { if(left_join) { real_index[ i ] = real_xindex[ xp-1 ]; for(j = 0; j < ncx; j++) { /* x-values */ ij_result = i + j * num_rows; ij_original = (xp-1) + j * nrx; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(x)[ ij_original ]; break; case INTSXP: int_result[ ij_result ] = int_x[ ij_original ]; break; case REALSXP: real_result[ ij_result ] = real_x[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(x)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(x, ij_original)); break; default: error("unsupported data type"); break; } } for(j = 0; j < ncy; j++) { /* y-values */ ij_result = i + (j+ncx) * num_rows; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(fill)[ 0 ]; break; case INTSXP: /*INTEGER(result)[ ij_result ] = INTEGER(fill)[ 0 ]; */ int_result[ ij_result ] = int_fill; break; case REALSXP: REAL(result)[ ij_result ] = REAL(fill)[ 0 ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ].r = REAL(fill)[ 0 ]; COMPLEX(result)[ ij_result ].i = REAL(fill)[ 0 ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(fill, 0)); break; default: error("unsupported data type"); break; } } } xp++; if(!left_join) i--; } else if( real_xindex[ xp-1 ] > real_yindex[ yp-1 ] ) { if(right_join) { real_index[ i ] = real_yindex[ yp-1 ]; for(j = 0; j < ncx; j++) { /* x-values */ ij_result = i + j * num_rows; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(fill)[ 0 ]; break; case INTSXP: /*INTEGER(result)[ ij_result ] = INTEGER(fill)[ 0 ];*/ int_result[ ij_result ] = int_fill; break; case REALSXP: REAL(result)[ ij_result ] = REAL(fill)[ 0 ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ].r = REAL(fill)[ 0 ]; COMPLEX(result)[ ij_result ].i = REAL(fill)[ 0 ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(fill, 0)); break; default: error("unsupported data type"); break; } } for(j = 0; j < ncy; j++) { /* y-values */ ij_result = i + (j+ncx) * num_rows; ij_original = (yp-1) + j * nry; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(y)[ ij_original ]; break; case INTSXP: int_result[ ij_result ] = int_y[ ij_original ]; break; case REALSXP: real_result[ ij_result ] = real_y[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(y)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(y, ij_original)); break; default: error("unsupported data type"); break; } } } yp++; if(!right_join) i--; } } } else if( TYPEOF(xindex) == INTSXP ) { for(i = 0; i < num_rows; i++) { /* If we are past the last row in x, assign NA to merged data and copy the y column values to the second side of result */ if( xp > nrx ) { if(right_join) { int_index[ i ] = int_yindex[ yp-1 ]; for(j = 0; j < ncx; j++) { /* x-values */ ij_result = i + j * num_rows; switch( mode ) { case LGLSXP: case INTSXP: /*INTEGER(result)[ ij_result ] = INTEGER(fill)[ 0 ];*/ int_result[ ij_result ] = int_fill; break; case REALSXP: REAL(result)[ ij_result ] = REAL(fill)[ 0 ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ].r = REAL(fill)[ 0 ]; COMPLEX(result)[ ij_result ].i = REAL(fill)[ 0 ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(fill, 0)); break; default: error("unsupported data type"); break; } } for(j = 0; j < ncy; j++) { /* y-values */ ij_result = i + (j+ncx) * num_rows; ij_original = (yp-1) + j * nry; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(y)[ ij_original ]; break; case INTSXP: int_result[ ij_result ] = int_y[ ij_original ]; break; case REALSXP: real_result[ ij_result ] = real_y[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(y)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(y, ij_original)); break; default: error("unsupported data type"); break; } } } yp++; if(!right_join) i--; /* if all=FALSE, we must decrement i for each non-match */ } else /* past the last row of y */ if( yp > nry ) { if(left_join) { /* record new index value */ int_index[ i ] = int_xindex[ xp-1 ]; /* copy values from x and y to result */ for(j = 0; j < ncx; j++) { // x-values ij_result = i + j * num_rows; ij_original = (xp-1) + j * nrx; //num_rows; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(x)[ ij_original ]; break; case INTSXP: int_result[ ij_result ] = int_x[ ij_original]; //INTEGER(result)[ ij_result ] = INTEGER(x)[ ij_original ]; break; case REALSXP: //REAL(result)[ ij_result ] = REAL(x)[ ij_original ]; real_result[ ij_result ] = real_x[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(x)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(x, ij_original)); break; default: error("unsupported data type"); break; } } /* we are out of y-values, so fill merged result with NAs */ for(j = 0; j < ncy; j++) { // y-values ij_result = i + (j+ncx) * num_rows; //REAL(result)[ ij_result ] = NA_REAL; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(fill)[ 0 ]; //NA_INTEGER; break; case INTSXP: int_result[ ij_result ] = int_fill; break; case REALSXP: REAL(result)[ ij_result ] = REAL(fill)[ 0 ]; //NA_REAL; break; case CPLXSXP: COMPLEX(result)[ ij_result ].r = REAL(fill)[ 0 ]; //NA_REAL; COMPLEX(result)[ ij_result ].i = REAL(fill)[ 0 ]; //NA_REAL; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(fill, 0)); //NA_STRING); break; default: error("unsupported data type"); break; } } } xp++; if(!left_join) i--; } else /* matching index values copy all column values from x and y to results */ //if( INTEGER(xindex)[ xp-1 ] == INTEGER(yindex)[ yp-1 ] ) { if( int_xindex[ xp-1 ] == int_yindex[ yp-1 ] ) { /* copy index FIXME this needs to handle INTEGER efficiently as well*/ //INTEGER(index)[ i ] = INTEGER(xindex)[ xp-1 ]; int_index[ i ] = int_xindex[ xp-1 ]; /* copy x-values to result */ for(j = 0; j < ncx; j++) { // x-values ij_result = i + j * num_rows; ij_original = (xp-1) + j * nrx; //num_rows; //REAL(result)[ ij_result ] = REAL(x)[ ij_original ]; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(x)[ ij_original ]; break; case INTSXP: int_result[ ij_result ] = int_x[ ij_original ]; //INTEGER(result)[ ij_result ] = INTEGER(x)[ ij_original ]; break; case REALSXP: //REAL(result)[ ij_result ] = REAL(x)[ ij_original ]; real_result[ ij_result ] = real_x[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(x)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(x, ij_original)); break; default: error("unsupported data type"); break; } } /* copy y-values to result */ for(j = 0; j < ncy; j++) { // y-values ij_result = i + (j+ncx) * num_rows; ij_original = (yp-1) + j * nry; //num_rows; //REAL(result)[ ij_result ] = REAL(y)[ ij_original ]; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(y)[ ij_original ]; break; case INTSXP: int_result[ ij_result ] = int_y[ ij_original ]; //INTEGER(result)[ ij_result ] = INTEGER(y)[ ij_original ]; break; case REALSXP: //REAL(result)[ ij_result ] = REAL(y)[ ij_original ]; real_result[ ij_result ] = real_y[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(y)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(y, ij_original)); break; default: error("unsupported data type"); break; } } xp++; yp++; } else //if( INTEGER(xindex)[ xp-1 ] < INTEGER(yindex)[ yp-1 ] ) { if( int_xindex[ xp-1 ] < int_yindex[ yp-1 ] ) { if(left_join) { //copyIndex(index, xindex, i, xp-1); //INTEGER(index)[ i ] = INTEGER(xindex)[ xp-1 ]; int_index[ i ] = int_xindex[ xp-1 ]; for(j = 0; j < ncx; j++) { // x-values ij_result = i + j * num_rows; ij_original = (xp-1) + j * nrx; //num_rows; //REAL(result)[ ij_result ] = REAL(x)[ ij_original ]; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(x)[ ij_original ]; break; case INTSXP: //INTEGER(result)[ ij_result ] = INTEGER(x)[ ij_original ]; int_result[ ij_result ] = int_x[ ij_original ]; break; case REALSXP: //REAL(result)[ ij_result ] = REAL(x)[ ij_original ]; real_result[ ij_result ] = real_x[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(x)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(x, ij_original)); break; default: error("unsupported data type"); break; } } for(j = 0; j < ncy; j++) { /* y-values */ ij_result = i + (j+ncx) * num_rows; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(fill)[ 0 ]; break; case INTSXP: int_result[ ij_result ] = int_fill; break; case REALSXP: REAL(result)[ ij_result ] = REAL(fill)[ 0 ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ].r = REAL(fill)[ 0 ]; COMPLEX(result)[ ij_result ].i = REAL(fill)[ 0 ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(fill, 0)); break; default: error("unsupported data type"); break; } } } xp++; if(!left_join) i--; } else //if( INTEGER(xindex)[ xp-1 ] > INTEGER(yindex)[ yp-1 ] ) { if( int_xindex[ xp-1 ] > int_yindex[ yp-1 ] ) { if(right_join) { //INTEGER(index)[ i ] = INTEGER(yindex)[ yp-1 ]; int_index[ i ] = int_yindex[ yp-1 ]; for(j = 0; j < ncx; j++) { // x-values ij_result = i + j * num_rows; //REAL(result)[ ij_result ] = NA_REAL; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(fill)[ 0 ]; //NA_INTEGER; case INTSXP: int_result[ ij_result ] = int_fill; break; case REALSXP: REAL(result)[ ij_result ] = REAL(fill)[ 0 ]; //NA_REAL; break; case CPLXSXP: COMPLEX(result)[ ij_result ].r = REAL(fill)[ 0 ]; //NA_REAL; COMPLEX(result)[ ij_result ].i = REAL(fill)[ 0 ]; //NA_REAL; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(fill, 0)); //NA_STRING); break; default: error("unsupported data type"); break; } } for(j = 0; j < ncy; j++) { // y-values ij_result = i + (j+ncx) * num_rows; ij_original = (yp-1) + j * nry; //num_rows; //REAL(result)[ ij_result ] = REAL(y)[ ij_original ]; switch( mode ) { case LGLSXP: LOGICAL(result)[ ij_result ] = LOGICAL(y)[ ij_original ]; break; case INTSXP: //INTEGER(result)[ ij_result ] = INTEGER(y)[ ij_original ]; int_result[ ij_result ] = int_y[ ij_original ]; break; case REALSXP: //REAL(result)[ ij_result ] = REAL(y)[ ij_original ]; real_result[ ij_result ] = real_y[ ij_original ]; break; case CPLXSXP: COMPLEX(result)[ ij_result ] = COMPLEX(y)[ ij_original ]; break; case STRSXP: SET_STRING_ELT(result, ij_result, STRING_ELT(y, ij_original)); break; default: error("unsupported data type"); break; } } } yp++; if(!right_join) i--; } } } /* following logic to allow for dimensionless xts objects (unsupported) to be used in Ops.xts calls This maps to how zoo behaves */ if(LOGICAL(retside)[0] && !LOGICAL(retside)[1] && isNull(getAttrib(x,R_DimSymbol))) { /* retside=c(T,F) AND is.null(dim(x)) */ setAttrib(result, R_DimSymbol, R_NilValue); } else if(LOGICAL(retside)[1] && !LOGICAL(retside)[0] && isNull(getAttrib(y,R_DimSymbol))) { /* retside=c(F,T) AND is.null(dim(y)) */ setAttrib(result, R_DimSymbol, R_NilValue); } else /* set Dim and DimNames */ if(num_rows >= 0 && (ncx + ncy) >= 0) { /* DIM */ PROTECT(attr = allocVector(INTSXP, 2)); INTEGER(attr)[0] = num_rows; INTEGER(attr)[1] = ncx + ncy; setAttrib(result, R_DimSymbol, attr); UNPROTECT(1); /* DIMNAMES */ if(!isNull(colnames)) { // only set DimNamesSymbol if passed colnames is not NULL SEXP dimnames, dimnames_x, dimnames_y, newcolnames; PROTECT(dimnames = allocVector(VECSXP, 2)); p++; PROTECT(dimnames_x = getAttrib(x, R_DimNamesSymbol)); p++; PROTECT(dimnames_y = getAttrib(y, R_DimNamesSymbol)); p++; PROTECT(newcolnames = allocVector(STRSXP, ncx+ncy)); p++; for(i = 0; i < (ncx + ncy); i++) { if( i < ncx ) { if(!isNull(dimnames_x) && !isNull(VECTOR_ELT(dimnames_x,1))) { SET_STRING_ELT(newcolnames, i, STRING_ELT(VECTOR_ELT(dimnames_x,1),i)); } else { SET_STRING_ELT(newcolnames, i, STRING_ELT(colnames, i)); } } else { // i >= ncx; if(!isNull(dimnames_y) && !isNull(VECTOR_ELT(dimnames_y,1))) { SET_STRING_ELT(newcolnames, i, STRING_ELT(VECTOR_ELT(dimnames_y,1),i-ncx)); } else { SET_STRING_ELT(newcolnames, i, STRING_ELT(colnames, i)); } } } SET_VECTOR_ELT(dimnames, 0, R_NilValue); // ROWNAMES are NULL if(LOGICAL(check_names)[0]) { SET_VECTOR_ELT(dimnames, 1, xts_make_names(newcolnames, env)); } else { SET_VECTOR_ELT(dimnames, 1, newcolnames); } //SET_VECTOR_ELT(dimnames, 1, newcolnames); // COLNAMES are passed in setAttrib(result, R_DimNamesSymbol, dimnames); } } else { // only used for zero-width results! xts always has dimension setAttrib(result, R_DimSymbol, R_NilValue); } setAttrib(result, xts_IndexSymbol, index); if(LOGICAL(retclass)[0]) setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol)); setAttrib(result, xts_ClassSymbol, getAttrib(x, xts_ClassSymbol)); copy_xtsAttributes(x, result); UNPROTECT(p); return result; } //}}} //SEXP mergeXts (SEXP all, SEXP fill, SEXP retclass, SEXP colnames, SEXP retside, SEXP env, SEXP args) /* called via .External("mergeXts", ...) */ SEXP mergeXts (SEXP args) // mergeXts {{{ { SEXP _x, _y, xtmp, result, _INDEX; /* colnames should be renamed as suffixes, as colnames need to be added at the C level */ SEXP all, fill, retc, retclass, symnames, suffixes, rets, retside, env, tzone, check_names; int nr, nc, ncs=0; int index_len; int i, n=0, P=0; SEXP argstart; args = CDR(args); all = CAR(args); args = CDR(args); fill = CAR(args); args = CDR(args); retclass = CAR(args); args = CDR(args); symnames = CAR(args); args = CDR(args); suffixes = CAR(args); args = CDR(args); retside = CAR(args); args = CDR(args); env = CAR(args); args = CDR(args); tzone = CAR(args); args = CDR(args); check_names = CAR(args); args = CDR(args); // args should now correspond to the ... objects we are looking to merge argstart = args; // use this to rewind list... n = 0; int type_of; int coerce_to_double=0; if(args != R_NilValue) type_of = TYPEOF(CAR(args)); while(args != R_NilValue) { if(length(CAR(args)) > 0) { ncs += ncols(CAR(args)); /* need to convert all objects if one non-zero-width needs to be converted */ if(TYPEOF(CAR(args)) != type_of) { coerce_to_double = 1; } } args = CDR(args); n++; } /* return empty xts if all objects have no columns */ if(ncs < 1) { SEXP s, t; PROTECT(s = t = allocList(1)); P++; SET_TYPEOF(s, LANGSXP); SETCAR(t, install("xts")); SEXP out = PROTECT(eval(s, env)); P++; UNPROTECT(P); return out; } /* build an index to be used in all subsequent calls */ args = argstart; _x = CAR(args); args = CDR(args); int leading_non_xts = 0; while( !isXts(_x) ) { if( args == R_NilValue ) error("no xts object to merge"); leading_non_xts = 1; /*warning("leading non-xts objects may have been dropped");*/ _x = CAR(args); args = CDR(args); } /* test for NULLs that may be present from cbind dispatch */ if(!leading_non_xts) { /* leading non-xts in 2 case scenario was igoring non-xts value */ if(n < 3 && (args == R_NilValue || (isNull(CAR(args)) && length(args) == 1))) {/* no y arg or y==NULL */ return(_x); } } if( args != R_NilValue) { _y = CAR(args); args = CDR(args); } else { PROTECT(_y = duplicate(_x)); P++; } if(n > 2 || leading_non_xts) { /*args != R_NilValue) {*/ /* generalized n-case optimization currently if n>2 this is faster and more memory efficient than recursively building a merged object, object by object. */ PROTECT(retc = allocVector(LGLSXP, 1)); P++; LOGICAL(retc)[0] = 1; /* return class == TRUE */ PROTECT(rets = allocVector(LGLSXP, 2)); P++; LOGICAL(rets)[0] = 0; /* don't return left */ LOGICAL(rets)[1] = 0; /* don't return right */ if( isNull(_y) ) { PROTECT(_y = duplicate(_x)); P++; } // REPROTECT _INDEX in while loop PROTECT_INDEX idx; PROTECT_WITH_INDEX(_INDEX = do_merge_xts(_x, _y, all, fill, retc, R_NilValue, R_NilValue, rets, check_names, env, coerce_to_double), &idx); P++; /* merge all objects into one zero-width common index */ while(args != R_NilValue) { if( !isNull(CAR(args)) ) { REPROTECT(_INDEX = do_merge_xts(_INDEX, CAR(args), all, fill, retc, R_NilValue, R_NilValue, rets, check_names, env, coerce_to_double), idx); } args = CDR(args); } index_len = length(GET_xtsIndex(_INDEX)); args = argstart; // reset args int ii, jj, iijj, jj_result; PROTECT(result = allocVector(TYPEOF(_INDEX), index_len * ncs)); P++; SEXP ColNames, NewColNames; PROTECT(NewColNames = allocVector(STRSXP, ncs)); P++; ncs = 0; // REPROTECT xtmp inside for loop PROTECT_INDEX idxtmp, cnmtmp; PROTECT_WITH_INDEX(xtmp = NULL, &idxtmp); P++; PROTECT_WITH_INDEX(ColNames = NULL, &cnmtmp); P++; for(i = 0, nc=0; args != R_NilValue; i = i+nc, args = CDR(args)) { // merge each object with index // i is object current being merged/copied // nc is offset in current object if( isNull(CAR(args)) ) { i = i-nc; continue; // if NULL is passed, skip to the next object. } REPROTECT(xtmp = do_merge_xts(_INDEX, CAR(args), all, fill, retclass, /*colnames*/R_NilValue, R_NilValue, retside, check_names, env, coerce_to_double), idxtmp); nr = nrows(xtmp); nc = (0 == nr) ? 0 : ncols(xtmp); // ncols(numeric(0)) == 1 ncs += nc; /* Use colnames from merged object, if it has them. Otherwise, use * use deparsed names */ REPROTECT(ColNames = getAttrib(CAR(args),R_DimNamesSymbol), cnmtmp); SEXP colnames = R_NilValue; if(R_NilValue != ColNames) { colnames = VECTOR_ELT(ColNames, 1); } if(R_NilValue == colnames) { for(jj=0; jj < nc; jj++) { SET_STRING_ELT(NewColNames, i+jj, STRING_ELT(symnames,i+jj)); } } else { for(jj=0; jj < nc; jj++) { SET_STRING_ELT(NewColNames, i+jj, STRING_ELT(colnames, jj)); } } switch(TYPEOF(xtmp)) { // by type, insert merged data into result object case LGLSXP: { int *xtmp_ = LOGICAL(xtmp); int *result_ = LOGICAL(result); for(jj=0; jj < nc; jj++) { for(ii=0; ii < nr; ii++) { iijj = ii + jj * nr; jj_result = ii + (i+jj) * nr; result_[jj_result] = xtmp_[iijj]; } } } break; case INTSXP: { int *xtmp_ = INTEGER(xtmp); int *result_ = INTEGER(result); for(jj=0; jj < nc; jj++) { for(ii=0; ii < nr; ii++) { iijj = ii + jj * nr; jj_result = ii + (i+jj) * nr; result_[jj_result] = xtmp_[iijj]; } } } break; case REALSXP: { double *xtmp_ = REAL(xtmp); double *result_ = REAL(result); for(jj=0; jj < nc; jj++) { for(ii=0; ii < nr; ii++) { iijj = ii + jj * nr; jj_result = ii + (i+jj) * nr; result_[jj_result] = xtmp_[iijj]; } } } break; case CPLXSXP: { Rcomplex *xtmp_ = COMPLEX(xtmp); Rcomplex *result_ = COMPLEX(result); for(jj=0; jj < nc; jj++) { for(ii=0; ii < nr; ii++) { iijj = ii + jj * nr; jj_result = ii + (i+jj) * nr; result_[jj_result] = xtmp_[iijj]; } } } break; case STRSXP: { for(jj=0; jj < nc; jj++) { for(ii=0; ii < nr; ii++) { iijj = ii + jj * nr; jj_result = ii + (i+jj) * nr; SET_STRING_ELT(result, jj_result, STRING_ELT(xtmp, iijj)); } } } break; default: error("unsupported data type"); break; } } if(ncs > 0) { SEXP dim; PROTECT(dim = allocVector(INTSXP, 2)); P++; INTEGER(dim)[0] = index_len; INTEGER(dim)[1] = ncs; setAttrib(result, R_DimSymbol, dim); SEXP dimnames; PROTECT(dimnames = allocVector(VECSXP, 2)); P++; SET_VECTOR_ELT(dimnames, 0, R_NilValue); // rownames are always NULL in xts /* colnames, assure they are unique before returning */ if(LOGICAL(check_names)[0]) { SET_VECTOR_ELT(dimnames, 1, xts_make_names(NewColNames, env)); } else { SET_VECTOR_ELT(dimnames, 1, NewColNames); } setAttrib(result, R_DimNamesSymbol, dimnames); } SET_xtsIndex(result, GET_xtsIndex(_INDEX)); copy_xtsCoreAttributes(_INDEX, result); copy_xtsAttributes(_INDEX, result); } else { /* 2-case optimization --- simply call main routine */ /* likely bug in handling of merge(1, xts) case */ PROTECT(result = do_merge_xts(_x, _y, all, fill, retclass, symnames /*R_NilValue*/, suffixes, retside, check_names, env, coerce_to_double)); P++; } SEXP index_tmp = getAttrib(result, xts_IndexSymbol); PROTECT(index_tmp); P++; if(isNull(tzone)) { setAttrib(index_tmp, xts_IndexTzoneSymbol, getAttrib(getAttrib(_x,xts_IndexSymbol), xts_IndexTzoneSymbol)); } else { setAttrib(index_tmp, xts_IndexTzoneSymbol, tzone); } copyMostAttrib(getAttrib(_x,xts_IndexSymbol), index_tmp); setAttrib(result, xts_IndexSymbol, index_tmp); UNPROTECT(P); return(result); } //}}} end of mergeXts xts/src/diff.c0000644000176200001440000001602313564762102012743 0ustar liggesusers/* # 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 . */ #include #include #include #include "xts.h" SEXP diffXts(SEXP x, SEXP lag, SEXP diff, SEXP arith, SEXP nap, SEXP dots) { return R_NilValue; } SEXP lagXts(SEXP x, SEXP k, SEXP pad) { SEXP result; int nrs, ncs; int i, j, ij, iijj, K, NApad; int mode; int P=0; /*PROTECT counter*/ int *int_result=NULL, *int_x=NULL; int *lgl_result=NULL, *lgl_x=NULL; double *real_result=NULL, *real_x=NULL; int *int_oindex=NULL, *int_nindex=NULL; double *real_oindex=NULL, *real_nindex=NULL; nrs = nrows(x); ncs = ncols(x); K = INTEGER(k)[ 0 ]; K = (K > nrs) ? nrs : K; mode = TYPEOF(x); NApad = INTEGER(pad)[ 0 ]; if(NApad) { PROTECT(result = allocVector(TYPEOF(x), nrs*ncs)); P++; } else { if(K > 0) { PROTECT(result = allocVector(TYPEOF(x), (nrs-K)*ncs)); P++; } else { PROTECT(result = allocVector(TYPEOF(x), (nrs+K)*ncs)); P++; } } switch( TYPEOF(x) ) { case LGLSXP: lgl_x = LOGICAL(x); lgl_result = LOGICAL(result); break; case INTSXP: int_x = INTEGER(x); int_result = INTEGER(result); break; case REALSXP: real_x = REAL(x); real_result = REAL(result); break; case CPLXSXP: case STRSXP: case VECSXP: case RAWSXP: break; default: error("unsupported type"); break; } for(i = 0; i < nrs; i++) { /* need to figue out how many duplicate values we have, in order to know how far to go back. probably best accomplished with some sort of look-ahead approach, though this may be messy if k is negative... something like: while( i+tmp+K < nrs && xindex[i] == xindex[i+tmp_K] ) tmp_K++; */ for(j = 0; j < ncs; j++) { ij = i + j * nrs; if(i < K || (K < 0 && i > (nrs+K-1)) ) { /* Pad NA values at beginning */ if(NApad) { switch ( mode ) { case LGLSXP: lgl_result[ ij ] = NA_INTEGER; break; case INTSXP: int_result[ ij ] = NA_INTEGER; break; case REALSXP: real_result[ ij ] = NA_REAL; break; case CPLXSXP: COMPLEX(result)[ij].r = NA_REAL; COMPLEX(result)[ij].i = NA_REAL; break; case STRSXP: SET_STRING_ELT(result, ij, NA_STRING); break; case VECSXP: SET_VECTOR_ELT(result, ij, R_NilValue); break; case RAWSXP: RAW(result)[ij] = (Rbyte) 0; break; default: error("matrix subscripting not handled for this type"); break; } /* NA insertion */ } /* NApad */ } else { iijj = i - K + j * nrs; /* move back K positions to get data */ if(!NApad && K > 0) ij = i - K + j * (nrs - K); /* if not padding, start at the correct spot */ if(!NApad && K < 0) ij = i + j * (nrs + K); /* if not padding, start at the correct spot */ switch ( mode ) { case LGLSXP: lgl_result[ ij ] = lgl_x[ iijj ]; break; case INTSXP: int_result[ ij ] = int_x[ iijj ]; break; case REALSXP: real_result[ ij ] = real_x[ iijj ]; break; case CPLXSXP: COMPLEX(result)[ij] = COMPLEX(x)[iijj]; break; case STRSXP: SET_STRING_ELT(result, ij, STRING_ELT(x, iijj)); break; case VECSXP: SET_VECTOR_ELT(result, ij, VECTOR_ELT(x, iijj)); break; case RAWSXP: RAW(result)[ij] = RAW(x)[iijj]; break; default: error("matrix subscripting not handled for this type"); break; } } } /* j-loop */ } /* i-loop */ setAttrib(result, R_ClassSymbol, getAttrib(x, R_ClassSymbol)); if(!NApad) { /* No NA padding */ SEXP oindex, nindex, dims; int nRows = (K > 0) ? nrs-K : nrs+K; int incr = (K > 0) ? K : 0; PROTECT(oindex = getAttrib(x, xts_IndexSymbol)); PROTECT(nindex = allocVector(TYPEOF(oindex), nRows)); switch(TYPEOF(oindex)) { case REALSXP: real_oindex = REAL(oindex); real_oindex = real_oindex + incr; real_nindex = REAL(nindex); for( i = 0; i < nRows; real_nindex++, real_oindex++, i++) *real_nindex = *real_oindex; break; case INTSXP: int_oindex = INTEGER(oindex); int_oindex = int_oindex + incr; int_nindex = INTEGER(nindex); for( i = 0; i < nRows; int_nindex++, int_oindex++, i++) *int_nindex = *int_oindex; break; default: break; } setAttrib(result, xts_IndexSymbol, nindex); PROTECT(dims = allocVector(INTSXP, 2)); INTEGER(dims)[0] = nRows; INTEGER(dims)[1] = ncs; setAttrib(result, R_DimSymbol, dims); setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); UNPROTECT(3); } else { /* NA pad */ setAttrib(result, xts_IndexSymbol, getAttrib(x, xts_IndexSymbol)); setAttrib(result, R_DimSymbol, getAttrib(x, R_DimSymbol)); setAttrib(result, R_DimNamesSymbol, getAttrib(x, R_DimNamesSymbol)); } setAttrib(result, xts_ClassSymbol, getAttrib(x, xts_ClassSymbol)); UNPROTECT(P); return result; } SEXP lag_xts (SEXP x, SEXP _k, SEXP _pad) { /* this will eventually revert to NOT changing R default behaviors for now it uses the 'standard' convention adopted by xts */ int k = asInteger(_k); /* ensure args are correct types; error if conversion fails */ if(k == NA_INTEGER) error("'k' must be integer"); if(asLogical(_pad) == NA_LOGICAL) error("'na.pad' must be logical"); k = k * -1; /* change zoo default negative handling */ return zoo_lag (x, ScalarInteger(k), _pad); } SEXP lagts_xts (SEXP x, SEXP _k, SEXP _pad) { /* this will use positive values of lag for carrying forward observations i.e. y = lagts(x, 1) is y(t) = x(t-1) */ int k = asInteger(_k)*-1; /* change zoo default negative handling */ /* ensure args are correct types; error if conversion fails */ if(k == NA_INTEGER) error("'k' must be integer"); if(asLogical(_pad) == NA_LOGICAL) error("'na.pad' must be logical"); return zoo_lag (x, ScalarInteger(k), _pad); } xts/vignettes/0000755000176200001440000000000013607332267013111 5ustar liggesusersxts/vignettes/xts.Rnw0000644000176200001440000010065413564762102014422 0ustar liggesusers%\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.Rnw0000644000176200001440000003003413564762102015161 0ustar liggesusers%\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, mean) period.apply(sample.xts, endpoints(sample.xts, "days"), mean) period.apply(sample.xts, endpoints(sample.xts, "hours", 6), mean) @ \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',], mean) @ \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/NEWS0000644000176200001440000004752713564762102011614 0ustar liggesusersChanged in xts 0.12-0: o All the index-attributes have been removed from the xts object and are now only attached to the index itself (#245). We took great care to maintain backward compatibility, and throw warnings when deprecated functions are called and when index-attributes are found on the xts object. But there still may be some breaking changes lurking in edge cases. o @SamoPP found one edge case (#297) where an error was thrown when index() was called on an xts object with an index that had no tclass attribute. o ...which led Joshua to find that the index setting functions did not always copy index attributes (#305). o Several binary operations (e.g. +, -, !=, <, etc.) on variations of uncommon xts objects with other xts, matrix, or vector objects, could result in malformed xts objects (#295). Some examples of the types of uncommon xts objects: no dim attribute, zero-width, zero-length. o Calling as.matrix() on an xts object without a dim attribute no longer throws an error (#294). o merge.xts() now honors check.names = FALSE (#293). o The possible values for major.ticks, minor.ticks, and grid.ticks.on in the Details section of ?plot.xts have been corrected. Thanks to Harvey Smith (@harvey131) for the report and patch (#291). o as.zoo.xts() is now only registered for zoo versions prior to 1.8-5. Methods to convert an object to another class should reside in the package that implements the target class. Thanks to Kurt Hornik for the report (#287). o .parseISO8601() no longer has a potential length-1 logical error. Thanks to Kurt Hornik for the report (#280). o endpoints() now honors k > 0 when on = "quarters". Thanks to @alkment for the report (#279). o Performance for the period.XYZ() functions (sum, prod, min, max) is much faster (#278). Thanks to Harvey Smith (@harvey131) for the report and examples. o merge.xts() now creates shorter column names when passed unnamed objects. This is now consistent with zoo (#248). o Time-of-day performance is ~200x faster, thanks to StackOverflow user3226167 (#193). Changed in xts 0.11-2: o The to.period() family of functions now use the index timezone when converting intraday index values to daily values (or lower frequency). Thanks to Garrett See and Gabor Grothendieck for the reports (#53, #277). o Make column names for merge() results with unnamed objects shorter and more like zoo (#248). This also makes na.fill() much faster (#259). BREAKING: This may break existing code for integer unnamed objects. o Fix subset when 'index(x)' and 'i' contain duplicates. Thanks to Stack Overflow user 'scs' (https://stackoverflow.com/users/4024268/scs) for the report, and Philippe Verspeelt for debugging (#275). o Fix if-statement in xts constructor that may use a logical with length > 1. Thanks to @HughParsonage for the report and PR (#270, #272). o Register shift.time.xts() method. Thanks to Philippe Verspeelt for the report and PR (#268, #273). o Conditionally register S3 methods for as.timeSeries.xts() and as.fts.xts() when their respective packages are available (as requested by CRAN). Note that this means these two functions are no longer exported. This may break some existing code that calls the methods directly, though 'best practice' is to let method dispatch determine which method to invoke. Changed in xts 0.11-1: o Fix regression in .xts() that caused 'tclass' argument/attribute to be incorrectly set to POSIXct regardless of user-provided value. Thanks to @Eluvias for the report and Tom Andrews for the PR (#249, #250). o Fix performance regression when xts object is subset by a date-time vector. Thanks to Tom Andrews for the report, and the PR to fix the bug in my patch (#251, #263, #264). o Restore behavior from 0.10-2 so subsetting an empty xts object by a date- time vector returns an empty xts object instead of throwing an error. Thanks to @alkment for the report (#252). o Add ability for merge.xts() to handle multiple character or complex xts objects. Thanks to Ken Williams for the report (#44). o Add ability to use "quarters" to specify tick/grid mark locations on plots. This ran but produced an incorrect result in 0.10-2 and threw an error in 0.11-0. Thanks to Marc Weibel for the report (#256). o Fix illegal read reported by valgrind. Thanks to Tom Andrews for the report and PR (#236, #264). Changed in xts 0.11-0: o Fix make.index.unique() to always return a unique and sorted index. Thanks to Chris Katsulis for the report and example (#241). o Add window.xts() method and completely refactor the internal binary search function it depends on. Thanks to Corwin Joy for the PR, tests, review, and patience (#100, #240). o Better axis tick mark locations for plots. Thanks to Dirk Eddelbuettel for the report (#246). Also incorporate axTicksByTime2() into axTicksByTime() to reduce code duplication from the migration of quantmod::chart_Series() to xts::plot.xts() (#74). o Add details to plot.xts() parameters that are periodicity, now that RStudio has argument completion. Thanks to Evelyn Mitchell for the PR (#154). o periodicity() now warns instead of errors if the xts object contains less than 2 observations (#230). o first() and last() now keep dims when they would otherwise be dropped by a regular row subset. This is consistent with head() and tail(). Thanks to Davis Vaughan for the report (#226). o Fix subset when ISO8601 string is outside the valid range, so it returns no data instead of all rows (#96). o Avoid partial name matches from parse.side() (inside .parseISO8601()) results that are passed to firstof() and lastof(). Thanks to @gp2x for the report and the patch (#231). o na.locf.xts() now loops over columns of multivariate objects in C code, instead of in R. This should improve speed and memory performance. Thanks to Chris Katsulis and Tom Andrews for their reports and patches (#232, #233, #234, #235, #237). o Change plot.xts() default 'pch = 0' (rectangles) to 'pch = 1' (circles) so it looks more like base and zoo plots (#203). Changed in xts 0.10-2: o na.locf.xts() and na.omit.xts() now support character xts objects. Thanks to Ken Williams and Samo Pahor for the reports (#42). o na.locf.xts() now honors 'x' and 'xout' arguments by dispatching to the next method (#215). Thanks to Morten Grum for the report. o coredata.xts() now functions the same as coredata.zoo() on zero-length objects, and only removes xts-related attributes (#223). Thanks to Vincent Guyader for the report. o plot.xts() no longer ignores 'col.up' and 'col.dn' when 'type="h"' (#224). Thanks to Charlie Friedemann for the report. This was inadvertently broken as part of the fix for #210. Changed in xts 0.10-1: o 'ylim' values passed to 'addSeries' and 'addPolygon' via '...' are now captured and honored (#220). o 'addPolygon' now checks for ylim of zeros, as 'addSeries' does (#164). o The 'base::as.Date.numeric' method is no longer over-ridden. The exported, but not registered, method in zoo should prevent any change in behavior. o Series added to an existing plot are now given the same index values as the main panel (#216). There still may be some weird behavior if the new data does not have observations within the timespan of the main panel data, but no observations on the same timestamps. o Existing 'par' values are now captured and reset before returning from plotting functions (#217). o User-defined 'col' values are now honored when 'type="h"' (#210). o Values passed to plotting functions are now copied from the calling environment. This enables plotting arguments to be objects passed through multiple layers of function calls. o indexFormat is now generic, consistent with indexFormat<- (#188). o Calling as.matrix() on a zero-width xts object now behaves consistently with zoo, and no longer throws an error (#130). o Fix weird result in merge.xts() when 'fill' argument is NULL or a zero- length vector (#261). o Fixed bug in endpoints() due to sub-second representation error via using integer division (%/%) with non- integer arguments (#202). o endpoints() gained sub-second accuracy on Windows (#202). o plot.xts() no longer errors when called on an object containing a constant value. It chooses ylim values +/-20% from the series value (#156). o plot.xts() now places y-axis labels in the same location on the plot, regardless of data periodicity (#85). o rbind.xts() now throws an error if passed an xts object with different number of observations in the index and data (e.g., zero-width) (#98). Changed in xts 0.10-0: Major changes include: o A new plot.xts() that is incompatible with earlier versions of plot.xts(). o Moved development from R-Forge to GitHub. o New xts FAQ. Other, less disruptive changes include: o merge.xts() now throws an error if the index contains non-finite values (#174). o Constructors xts() and .xts() now ensure order.by and index arguments do not contain non-finite values. Many xts functions, most notably merge.xts(), expect all index values to be finite. Missing index values usually indicate an error, and always occurred at the end of the index (#173, #194, #199). o Fixed bug in endpoints() when called on sparse data that have the same month and day, but different years (#169). o Fixed bug in [.xts did not do the same checks on logical xts objects as it does for all other data types (#163). o Fixed bug that caused split.xts() to error if 'f' is a character vector with more than 1 element (#134). o Fixed bug that crashed R if 'k' argument to lag.xts() was not an integer and would be NA when coerced to integer (#152). o period.apply() now checks to ensure the object's index is unique and sorted, and sets INDEX <- sort(unique(INDEX)) if it is not. It also ensures INDEX starts with 0 and ends with NROW(x) (#171). o All references to the 'its' package have been removed, since it is now archived on CRAN at the request of its maintainer. o Fixed bug that crashed R when merge.xts() was called on an empty xts object and more than one non-xts object (#157). o Fixed bug that did not set the index's tzone attribute to UTC when index<-.xts or indexClass<- were called and 'value' did not have a tzone attribute (#148). o Fixed a bug in endpoints() that caused incorrect results if the index was less than the epoch (#144). o Fixed a bug that caused diff.xts() on a logical xts object to return an object with a POSIXct index. o index.xts() works even if the package containing the class for the index is not attached (it needs to be loaded, however). o [.xts now returns NA if a one-column xts object is subsect by NA, instead of throwing an uninformative error (#97). o Fixed bugs that would crash R when [.xts was called a certain way and 'j' contained NA values (#97, #181). o Fixed a bug in endpoints() where 1 second would be subtracted for any date in the year 1969. The subtraction is only supposed to occur on 1969-12-31 23:59:59.9... to work around behavior in strptime(). o timeBasedSeq() now honors hour/min/sec 'BY' values (#91). o [.xts now throws an error if 'j' is character and not one of the column names. This is consistent with [.zoo and [.matrix (#48). o timeBasedSeq() now works correctly when resolution is "days" the sequence includes a daylight saving time change (#67). o Explicitly set indexTZ="UTC" for all index classes that do not have a TZ (#66). indexTZ="GMT" is also allowed. o Fixed as.xts() when called on an 'mts' object (#64). o Moved development from R-Forge to GitHub. o Fixed bug in to.period() that errored when name=NULL (#5937). o Fixed bug in .index* functions that did not account for timezones (#5891). o Fixed bug that allowed index<-.xts to produce an unsorted index (#5893). o Fixed bug so subsetting a zero-width xts object with a zero-length 'i' vector no longer returns an object with column names (#5885). o Updated [.xts to handle 'i' containing multiple zeros (e.g. subsetting by a "logical" column of an integer xts object). o endpoints() now errors if k < 0. Changed in xts 0.9-7: o Fixed bug that caused logical operators on xts objects to drop the 'tzone' attribute (#2750). o Fixed bug that ignored 'which.i' argument to [.xts on zero-width xts objects (#2753). o Fixed bug where xts() does not sort 'order.by' if x is missing (#4775). Changed in xts 0.9-6: o Fixed bug where setting dimnames to NULL would break as.xts() (#4794). o Added checks to period.sum/prod/min/max to ensure INDEX is in [0,nrow(x)]. o Fixed missing argument to na_locf() in the C/C++ xtsAPI (Dirk Eddelbuettel). Changed in xts 0.9-5: o Increased zoo dependency version to 1.7-10 for changes in C code. o Fixed several minor issues in the C/C++ xtsAPI (Dirk Eddelbuettel). Changed in xts 0.9-4: o Fixed bug where the index was missing the 'tzone' attribute. o Fixed to.period() bug when 'indexAt' is "firstof" or "lastof". (bug #2691, patch #2710, thanks to Garrett See) o Fixed subsetting bug on zero-width xts objects that returned NA data and an NA index (#2669). o xts' merge() method now has 'drop' and 'check.names' arguments to match the zoo merge() method. o 'index<-' now correctly handles UTC Date objects when resetting index values. '.index<-' behaved correctly. o xts' rollapply() method now handles the 'fill' argument. o Added several functions to the C/C++ API: - make_index_unique - make_unique - endpoints - do_merge_xts - na_omit_xts - na_locf o Fixed xts' rollapply() method when input has one column, but function output has more than one column. Changed in xts 0.9-3: o No user-visible changes. Changed in xts 0.9-2: o Added C/C++ xtsAPI (Dirk Eddelbuettel) o Added tzone() and tclass() functions as aliases to indexTZ() and indexClass(), respectively. Eventually will Deprecate/Defunct the former. Changed in xts 0.9-1: o xts() now ignores timezone arguments when order.by is Date class, with a warning. Changed in xts 0.8-8: o Modified str() output to make use of proper ISO-8601 range formating o Fixed bug in reclass() when 'tzone' of object is different than system TZ. o Fixed bug in xts() that dropped dims when 'x' is a 1-column matrix or data.frame. o [.xts no longer warns if 'i' is zero-length. o to.period() now checks that 'x' is not zero-length/width. o Fixed edge case in Ops.xts where two objects with no common index create an invalid 'xts' object with no index. o to.monthly() and to.quarterly() now default to drop.time=TRUE. o Internal .drop.time() now changes the index class to Date. This affects the to.period() family of functions. o Restore Date index/tclass conversion to POSIXct with a UTC timezone via integer division instead of double-precision division. Changed in xts 0.8-6: o Revert Date index/tclass conversion to POSIXct with a UTC timezone to previous behavior as in 0.8-2. Changed in xts 0.8-5: o A Date index/tclass is now internally converted to POSIXct with a UTC timezone ensure proper conversion regardless of user TZ settings. o tclass is now an argument to .xts() o Fix endpoints() properly handles millisecond time stamps (and microsecond on not Windows). o Subsetting zero-width xts objects now behaves like zoo, with NA values returned for valid row requests. Changed in xts 0.8-2: o Fixed bug in lag() and diff() for character coredata. o Fixed subsetting bug that returned a contiguous chunk of data even when a non-contiguous 'i' was provided. o Fixed bug that ignored FinCenter/TZ for timeDate index o period.apply() now only sets colnames if the number of columns in the input and output are equal. o Fixed periodicity() when scale = "yearly" o Fixed [.xts when row-subsetting via a POSIXct vector, which returned an object full of NA. o Added '...' to axis() call inside of plot.xts() to allow for 'cex.axis' and 'cex.lab' to be passed in. o Fixed axes=FALSE issue in plot.xts(). o Dependency now on 1.7-0 or better of zoo (R-forge at present) This build now links to C code moved from xts to zoo. At present this is only for zoo_lag (used in lag and lagts) o Added 'drop' and 'fromLast' arguments to make.index.unique(). o Added adj.time() and shift.time() o Fixed na.locf() bug that would fill trailing NA larger than 'maxgap' observations (#1319) o Updated indexFormat() documentation and add an example Changed in xts 0.8-0: o Fix print formatting (#1080) o Fix bug related to na.locf() and zero-width objects (#1079) o Add .RECLASS = FALSE after '...' for as.xts.*() methods. This makes all as.xts.*() methods one-way (i.e. not reclass-able). Objects converted to xts via try.xts() can still be converted back to their original class via relcass(). o Fix bug that caused colnames to be dropped if object is subset by time that is not in the index. Changes in xts 0.7-5: o try.xts and reclass now are more efficient on xts objects, no longer appending a .RECLASS attribute. This penalty (copying) is shifted to classes that are internally converted to xts. Changes in xts 0.7-4: o internal attributes of index are now maintaining timezone (tzone), time class (tclass) information. o `[.xts` method is now using new C code. This may revert back as character-based objects are not supported. Changed for future code refactoring into zoo, as well as performance gains on integer, double and logical values. Also added in checks for NAs. drop=TRUE now works correctly in all known applications. o (cbind)merge.xts and rbind.xts now copy index attributes to handle internal changes to index characteristics (in C code) o indexTZ.Rd updated to provide information regarding internal changes. Also indexTZ<- is now exported to facilitate timezone changing of xts objects. Changes in xts 0.7-1: o subsecond ISO8601 subsetting on dates before 1970 (epoch) is disabled. This is due to a bug in the R implementation of POSIX handling of fractional seconds pre-1970. 10 microsecond granularity is still functional for all other times. Thanks to Andreas Noack Jensen for the early bug report. o new 'tzone' arg in xts constructor and 'tz' in .parseISO8601 allows for future support of non-system TZ dependent indexing o internal index attribute (numeric) now can have attributes set (tzone is currently the only one used in xts). These should remain during all xts operations. Still experimental. o naCheck has been exposed at the C level for use in packages "LinkingTo: xts". See ?xtsAPI for more details. Changes in xts 0.7-0: o A new NEWS file. o print.xts now passes ... o endpoints speedup and bug fix (thanks Ismail Onur Filiz) o na.omit bug on logical and NaN fixes (thanks Fabrizio Pollastri and Koert Kuipers) o fromLast=FALSE for na.locf.xts. Matching to zoo. (thanks to Sandor Benczik) o LGLSXP support in leadingNA (R fun naCheck) o fixed logical and NA 'j' subsetting. Thanks Koert Kuipers. o as.xts and as.timeSeries fixes for timeSeries changes o merge and subset now support dimensionless xts (non-standard). merge segfault fixed when merging all 3 or more zero-width xts objects and only zero-width objects. Thanks to Koert Kuipers for the report. o added which.i to [.xts to return i values found via ISO8601 subset string o new lines.xts and plot.xts, similar to methods in zoo o lastof now has sec to 10 microsecond precision, and subsec arg to append to secs. o xts() further consistency in NROW/index check o align.time error checks for positive n= values (thanks Brian Peterson) o toPeriod updates in C, almost exported. ~600-1200x faster o new lag_xts in C. Increased speed and index flexibility. o endpoints 'days' bug fix o .makeISO8601 function to create ISO8601 compliant string from xts objects xts/R/0000755000176200001440000000000013607332267011302 5ustar liggesusersxts/R/POSIX.R0000644000176200001440000000153713564762102012332 0ustar liggesusers# # 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.xts.POSIXt <- function(x, ...) { xts(NULL, order.by=x) } xts/R/as.environment.xts.R0000644000176200001440000000164313564762102015211 0ustar liggesusers# # 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.environment.xts <- function(x) { e <- new.env() lapply(1:NCOL(x), function(.) assign(colnames(x)[.], x[,.],envir=e)) e } xts/R/parse8601.R0000644000176200001440000001330213564762102013052 0ustar liggesusers# # 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 .makeISO8601 <- function(x) { paste(start(x),end(x),sep="/") } .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/print.R0000644000176200001440000000261013564762102012555 0ustar liggesusers# # 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.xts` <- function(x,fmt,...) { check.TZ(x) if(missing(fmt)) fmt <- tformat(x) if(is.null(fmt)) fmt <- TRUE xx <- coredata(x, fmt) if(length(xx) == 0) { if(!is.null(dim(x))) { p <- structure(vector(storage.mode(xx)), dim = dim(x), dimnames = list(format(index(x)),colnames(x))) print(p) } else { cat('Data:\n') print(vector(storage.mode(xx))) cat('\n') cat('Index:\n') index <- index(x) if(length(index) == 0) { print(index) } else { str(index(x)) } } } else print(xx, ...) } xts/R/period.R0000644000176200001440000000605113564762102012706 0ustar liggesusers# # 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 . # optimized periodic apply functions # `is.timeBased` <- `timeBased` <- function(x) { if (!any(sapply(c("Date", "POSIXt", "chron", "dates", "times", "timeDate", "yearmon", "yearqtr", "xtime"), function(xx) inherits(x, xx)))) { FALSE } else TRUE } make.timeBased <- function(x, class='POSIXct', ...) { do.call(class, list(x,...)) } `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("xts_period_sum", xx, ep, PACKAGE = "xts") if(timeBased(index(x))) { tz <- xts(xa, index(x)[ep[-1]]) } else { tz <- zoo(xa, index(x)[ep[-1]]) } tz } `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("xts_period_prod", xx, ep, PACKAGE = "xts") if(timeBased(index(x))) { tz <- xts(xa, index(x)[ep[-1]]) } else { tz <- zoo(xa, index(x)[ep[-1]]) } tz } `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("xts_period_max", xx, ep, PACKAGE = "xts") if(timeBased(index(x))) { tz <- xts(xa, index(x)[ep[-1]]) } else { tz <- zoo(xa, index(x)[ep[-1]]) } tz } `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("xts_period_min", xx, ep, PACKAGE = "xts") if(timeBased(index(x))) { tz <- xts(xa, index(x)[ep[-1]]) } else { tz <- zoo(xa, index(x)[ep[-1]]) } tz } xts/R/index.R0000644000176200001440000001251513564771030012535 0ustar liggesusers# # 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 . index.xts <- time.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(length(x.index) == 0) return(integer()) 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]])) ) } `time<-.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(any(class(value) %in% .classesWithoutTZ)) { 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) } `.index` <- function(x, ...) { if(is.list(attr(x, "index"))) { attr(x, 'index')[[1]] } else attr(x, "index") } `.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) } `.indexsec` <- function(x) { as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$sec } `.indexmin` <- function(x) { as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$min } `.indexhour` <- function(x) { as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$hour } `.indexmday` <- function(x) { as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$mday } `.indexmon` <- function(x) { as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$mon } `.indexyear` <- function(x) { as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$year } `.indexwday` <- function(x) { as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$wday } `.indexbday` <- function(x) { # is business day T/F as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$wday %% 6 > 0 } `.indexyday` <- function(x) { as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$yday } `.indexisdst` <- function(x) { as.POSIXlt(.POSIXct(.index(x), tz=tzone(x)))$isdst } `.indexDate` <- `.indexday` <- function(x) { .index(x) %/% 86400L } `.indexweek` <- function(x) { (.index(x) + (3 * 86400)) %/% 86400 %/% 7 } `.indexyweek` <- function(x) { ((.index(x) + (3 * 86400)) %/% 86400 %/% 7) - ((startOfYear() * 86400 + (3 * 86400)) %/% 86400 %/% 7)[.indexyear(x) + 1] } xts/R/xts.R0000644000176200001440000002163413607330714012244 0ustar liggesusers# # 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 core functions # additional methods are in correspondingly named .R files # current conversions include: # timeSeries, its, irts, ts, matrix, data.frame, and zoo # MISSING: fts, tis, fame # # this file includes the main xts constructor as well as the reclass # function. # # xts methods (which match foreign conversion methods in other files) # are also defined below `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(inherits(order.by, .classesWithoutTZ)) { if(!missing(tzone)) warning(paste(sQuote('tzone'),"setting ignored for ", paste(class(order.by), collapse=", "), " indexes")) tzone <- "UTC" } #if(NROW(x) != length(order.by)) if(NROW(x) > 0 && NROW(x) != length(order.by)) stop("NROW(x) must match length(order.by)") orderBy <- class(order.by) if(inherits(order.by, 'Date')) { # convert to GMT POSIXct if specified order.by <- .POSIXct(unclass(order.by)*86400, tz=tzone) } 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) || length(x) != 0 ) { x <- as.matrix(x) } else x <- numeric(0) if(orderBy[1L] == "timeDate" && missing(tzone)) { tzone <- order.by@FinCenter } else if(!is.null(attr(order.by,"tzone")) && missing(tzone)) tzone <- attr(order.by, "tzone") if(inherits(order.by,'dates')) index <- as.numeric(as.POSIXct(strptime(as.character(order.by),"(%m/%d/%y %H:%M:%S)"))) #$format else index <- as.numeric(as.POSIXct(order.by)) if(any(!is.finite(index))) stop("'order.by' cannot contain 'NA', 'NaN', or 'Inf'") # xts' tzone must only contain one element (POSIXlt tzone has 3) tzone <- tzone[1L] x <- structure(.Data=x, index=structure(index,tzone=tzone,tclass=orderBy), class=c('xts','zoo'), ...) ctor.call <- match.call(expand.dots = TRUE) if(hasArg(".indexFORMAT")) { warning(sQuote(".indexFORMAT"), " is deprecated, use tformat instead.") if(missing("tformat")) { attr(attr(x, "index"), "tformat") <- eval.parent(ctor.call$.indexFORMAT) } } if(hasArg(".indexCLASS")) { warning(sQuote(".indexCLASS"), " is deprecated, use tclass instead.") if(missing("tclass")) { attr(attr(x, "index"), "tclass") <- eval.parent(ctor.call$.indexCLASS) } } if(hasArg(".indexTZ")) { warning(sQuote(".indexTZ"), " is deprecated, use tzone instead.") if(missing("tzone")) { attr(attr(x, "index"), "tzone") <- eval.parent(ctor.call$.indexTZ) } } 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 } `.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') } if(!is.numeric(index) && timeBased(index)) index <- 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))) 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) ctor.call <- match.call(expand.dots = TRUE) tformat <- NULL 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) } else { tformat <- attr(index, "tformat") } if(hasArg(".indexCLASS")) { warning(sQuote(".indexCLASS"), " is deprecated, use tclass instead.") tclass <- eval.parent(ctor.call$.indexCLASS) } else if(missing("tclass")) { # compare tclass on the index with tclass argument because the # tclass argument will override the index attribute, but it shouldn't... index.class <- attr(index, 'tclass') default.class <- c("POSIXct", "POSIXt") ### FIXME: ### This warning causes errors in dependencies (e.g. portfolioBacktest, ### when the warning is thrown from PerformanceAnalytics). Reinstate this ### warning after fixing downstream packages. ### if(!is.null(index.class) && !all(index.class %in% default.class)) { ### warning("the index tclass attribute is ", index.class, ### " but will be changed to (POSIXct, POSIXt)") ### } } if(hasArg(".indexTZ")) { warning(sQuote(".indexTZ"), " is deprecated and will be ignored,", " use tzone instead.") } # don't overwrite index tzone if tzone arg is missing if(missing("tzone")) { if(!is.null(index.tz <- attr(index,'tzone'))) tzone <- index.tz } # xts' tzone must only contain one element (POSIXlt tzone has 3) tzone <- tzone[1L] xx <- .Call("add_xtsCoreAttributes", x, index, tzone, tclass, c('xts','zoo'), tformat, PACKAGE='xts') # 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) } xx } `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),tzone=tzone(match.to)) attr(x, ".CLASS") <- CLASS(match.to) xtsAttributes(x) <- xtsAttributes(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(x) <- attr(x,'.ROWNAMES')[1:NROW(x)] } #else rownames(x) <- NULL } 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 } } #`reclass` <- reclass2 `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") } `CLASS<-` <- function(x,value) { UseMethod("CLASS<-") } `CLASS<-.xts` <- function(x,value) { attr(x,".CLASS") <- value x } `is.xts` <- function(x) { inherits(x,'xts') && is.numeric(.index(x)) && !is.null(tclass(x)) } `as.xts` <- function(x,...) { UseMethod('as.xts') } #as.xts.default <- function(x, ...) x `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.to.xts` <- function(x,...) { return(x) } xts/R/utils.R0000644000176200001440000000206513564762102012565 0ustar liggesusers# # 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("naCheck", x, TRUE, PACKAGE='xts') } else NAs <- .Call("naCheck", rowSums(x), TRUE, PACKAGE='xts') ret <- list() ret$NAs <- NAs ret$nonNA <- (1+NAs):NROW(x) ret$beg <- n+NAs invisible(ret) } xts/R/periodicity.R0000644000176200001440000001134013564762102013745 0ustar liggesusers# # 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) } periodicity <- function(x, ...) { if( timeBased(x) || !is.xts(x) ) x <- try.xts(x, error='\'x\' needs to be timeBased or xtsible') 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) } else { p <- median(diff( .index(x) )) } units <- 'days' # the default if p > hourly scale <- 'yearly'# the default for p > quarterly label <- 'year' 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) { units <- "hours" scale <- "hourly" label <- "hour" } else if(p == 86400) { scale <- "daily" label <- "day" } else if( p <= 604800) { # 86400 * 7 scale <- 'weekly' label <- "week" } else if( p <= 2678400 ) { # 86400 * 31 scale <- 'monthly' label <- "month" } else if( p <= 7948800 ) { # 86400 * 92 scale <- 'quarterly' label <- "quarter" } structure(list(difftime = structure(p,units=units,class='difftime'), frequency = p, start = start(x), end = end(x), units = units, scale = scale, label = label), class = 'periodicity') } `periodicity.old` <- function (x, ...) { if(!is.xts(x)) x <- as.xts(x) # convert if necessary to usable format if(!tclass(x)[[1]] %in% c('Date','POSIXt')) tclass(x) <- "POSIXct" # this takes a long time on big data - possibly use some sort of sampling instead??? p <- median(diff(time(x))) if (is.na(p)) stop("cannot calculate periodicity from one observation") p.numeric <- as.numeric(p) units <- attr(p, "units") if (units == "secs") { scale <- "seconds" } if (units == "mins") { scale <- "minute" if (p.numeric > 59) scale <- "hourly" } if (units == "hours") { scale <- "hourly" } if (units == "days") { scale <- "daily" if (p.numeric > 1) scale <- "weekly" if (p.numeric > 7) scale <- "monthly" if (p.numeric > 31) scale <- "quarterly" if (p.numeric > 91) scale <- "yearly" } structure(list(difftime = p, frequency = p.numeric, start = index(first(x)), end = index(last(x)), units = units, scale = scale),class="periodicity") # class(xx) <- "periodicity" # xx # used when structure was assigned to xx, useless now, remain until testing is done though -jar } `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/zzz.R0000644000176200001440000000513113564762102012257 0ustar liggesusers# # 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)) } ) } .onLoad <- function(libname, pkgname) { # if(Sys.getenv("TZ") == "") { # packageStartupMessage("xts now requires a valid TZ environment variable to be set") # packageStartupMessage(" no TZ var is set, setting to TZ=GMT") # Sys.setenv(TZ="GMT") # } else { # packageStartupMessage("xts now requires a valid TZ environment variable to be set") # packageStartupMessage(" your current TZ:",paste(Sys.getenv("TZ"))) # } if (getRversion() < "3.6.0") { register_s3_method("timeSeries", "as.timeSeries", "xts") register_s3_method("fts", "as.fts", "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/Date.R0000644000176200001440000000154313564762102012302 0ustar liggesusers# # 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.xts.Date` <- function(x,...) { xts(x=NULL,order.by=x,...) } xts/R/timeSeries.R0000644000176200001440000000551013564762102013534 0ustar liggesusers# # 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") # 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::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,...) } `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") timeSeries::timeSeries(data=coredata(x), charvec=as.character(index(x)), ...) } `xts.as.timeSeries` <- function(x,...) {} xts/R/align.time.R0000644000176200001440000000502513564762102013453 0ustar liggesusers# # 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.time <- function(x, ...) { UseMethod("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,...)) } 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)) } is.index.unique <- is.time.unique <- function(x) { UseMethod("is.time.unique") } is.time.unique.xts <- function(x) { isOrdered(.index(x), strictly=TRUE) } is.time.unique.zoo <- function(x) { isOrdered(index(x), strictly=TRUE) } make.index.unique <- make.time.unique <- function(x, eps=0.000001, drop=FALSE, fromLast=FALSE, ...) { UseMethod("make.index.unique") } make.index.unique.xts <- function(x, eps=0.000001, drop=FALSE, fromLast=FALSE, ...) { if( !drop) { .Call('make_index_unique', x, eps, PACKAGE="xts") } else { x[.Call('non_duplicates', .index(x), fromLast, PACKAGE="xts")] } } make.index.unique.numeric <- function(x, eps=0.000001, drop=FALSE, fromLast=FALSE, ...) { if( !drop) { .Call('make_unique', x, eps, PACKAGE="xts") } else { x[.Call('non_duplicates', x, fromLast, PACKAGE="xts")] } } make.index.unique.POSIXct <- function(x, eps=0.000001, drop=FALSE, fromLast=FALSE, ...) { if( !drop) { .Call('make_unique', x, eps, PACKAGE="xts") } else { x[.Call('non_duplicates', x, fromLast, PACKAGE="xts")] } } xts/R/split.R0000644000176200001440000000206213564762102012555 0ustar liggesusers# # 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 . 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] lapply(1:length(ep), function(X) x[sp[X]:ep[X]]) } else NextMethod("split") } xts/R/modify.args.R0000644000176200001440000000500713564762102013646 0ustar liggesusers# # 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) } # This is how it is used in quantstrat in applyIndicators() # # replace default function arguments with indicator$arguments # .formals <- formals(indicator$name) # .formals <- modify.args(.formals, indicator$arguments, dots=TRUE) # # now add arguments from parameters # .formals <- modify.args(.formals, parameters, dots=TRUE) # # now add dots # .formals <- modify.args(.formals, NULL, ..., dots=TRUE) # # remove ... to avoid matching multiple args # .formals$`...` <- NULL # # tmp_val <- do.call(indicator$name, .formals) xts/R/all.equal.R0000644000176200001440000000221113564762102013274 0ustar liggesusers# # 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 } } NextMethod("all.equal") } xts/R/nperiods.R0000644000176200001440000000245713564762102013255 0ustar liggesusers# # 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 . `nseconds` <- function(x) { length(endpoints(x,on='seconds'))-1 } `nminutes` <- function(x) { length(endpoints(x,on='minutes'))-1 } `nhours` <- function(x) { length(endpoints(x,on='hours'))-1 } `ndays` <- function(x) { length(endpoints(x,on='days'))-1 } `nweeks` <- function(x) { length(endpoints(x,on='weeks'))-1 } `nmonths` <- function(x) { length(endpoints(x,on='months'))-1 } `nquarters` <- function(x) { length(endpoints(x,on='quarters'))-1 } `nyears` <- function(x) { length(endpoints(x,on='years'))-1 } xts/R/coredata.xts.R0000644000176200001440000000770613564762102014033 0ustar liggesusers# # 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 . 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("coredata_xts", x, PACKAGE="xts")) } `xcoredata.default` <- function(x,...) { x.attr <- attributes(x) original.attr <- x.attr[!names(x.attr) %in% c('dim','dimnames')] original.attr } `xcoredata` <- function(x,...) { UseMethod('xcoredata') } `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) } } `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 } `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/toperiod.R0000644000176200001440000001765513564762102013265 0ustar liggesusers# # 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 . # to.period functionality from quantmod # # to.period base function # to.minutes # to.hourly # to.daily # to.weekly # to.monthly # to.quarterly # to.yearly 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(!OHLC) { xx <- x[endpoints(x, period, k),] } 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("toPeriod", x, endpoints(x, period, k), has.Vo(x), has.Vo(x,which=TRUE), has.Ad(x) && is.OHLC(x), index_at, cnames, PACKAGE='xts') } 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) } `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,...) } `to.minutes3` <- function(x,name,...) { if(missing(name)) name <- deparse(substitute(x)) to.period(x,'minutes',k=3,name=name,...) } `to.minutes5` <- function(x,name,...) { if(missing(name)) name <- deparse(substitute(x)) to.period(x,'minutes',k=5,name=name,...) } `to.minutes10` <- function(x,name,...) { if(missing(name)) name <- deparse(substitute(x)) to.period(x,'minutes',k=10,name=name,...) } `to.minutes15` <- function(x,name,...) { if(missing(name)) name <- deparse(substitute(x)) to.period(x,'minutes',k=15,name=name,...) } `to.minutes30` <- function(x,name,...) { if(missing(name)) name <- deparse(substitute(x)) to.period(x,'minutes',k=30,name=name,...) } `to.hourly` <- function(x,name,...) { if(missing(name)) name <- deparse(substitute(x)) to.period(x,'hours',name=name,...) } `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) } `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) } `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) } `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) } `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(any(tclass(x) %in% .classesWithoutTZ)) { 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") } # if(!OHLC) { # xx <- x[endpoints(x, period, k),] # } 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 # 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("toPeriod", x, ep, has.Vo(x), has.Vo(x,which=TRUE), has.Ad(x) && is.OHLC(x), FALSE, cnames, PACKAGE='xts') reclass(xx,xo) } xts/R/list.R0000644000176200001440000000213313564762102012374 0ustar liggesusers# # 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/sort.xts.R0000644000176200001440000000175613564762102013237 0ustar liggesusers# # 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 . `sort.xts` <- function(x, decreasing=FALSE, MARGIN=1, ...) { if(NCOL(x) > 1) { as.matrix(x)[order(x[,MARGIN],decreasing=decreasing,...),] } else as.matrix(x)[order(x,decreasing=decreasing,...),] } xts/R/xts.methods.R0000644000176200001440000002426713564762102013715 0ustar liggesusers# # 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) { timestringToSeconds <- function(timeString) { # "09:00:00" to seconds of day origin <- paste("1970-01-01", timeString) as.numeric(as.POSIXct(origin, "UTC")) %% 86400L } # handle timezone tz <- indexTZ(x) secOfDay <- as.POSIXlt(index(x), tz = tz) secOfDay <- secOfDay$hour*60*60 + secOfDay$min*60 + secOfDay$sec secBegin <- timestringToSeconds(fromTimeString) secEnd <- timestringToSeconds(toTimeString) 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('_do_subset_xts', x, i, j, FALSE, PACKAGE='xts') } `.subset.xts` <- `[.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) return( xts(rep(NA,length(index(x))), index(x))[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)) { #if(any(i < 0)) { if(.Call("any_negative", i, PACKAGE="xts")) { 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)) { if(length(i) == 1 && !identical(integer(),grep("^T.*?/T",i[1]))) { # is i of the format T/T? ii <- gsub("T", "", i, fixed = TRUE) ii <- strsplit(ii, "/", fixed = TRUE)[[1L]] 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) { x.tmp <- .xts(rep(NA,length(i)), .index(x)[i], dimnames=list(NULL, colnames(x))) return(x.tmp) } else { if(USE_EXTRACT) { return(.Call('extract_col', x, as.integer(1:nc), drop, as.integer(i[1]), as.integer(i[length(i)]), PACKAGE="xts")) } else { return(.Call('_do_subset_xts', x, as.integer(i), as.integer(1:nc), drop, PACKAGE='xts')) } } } else # test for negative subscripting in j if (is.numeric(j)) { 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) return(.xts(coredata(x)[i,j,drop=FALSE], index=.index(x)[i])) } if(missing(i)) return(.Call("extract_col", x, as.integer(j), drop, 1, nr, PACKAGE='xts')) if(USE_EXTRACT) { return(.Call('extract_col', x, as.integer(j), drop, as.integer(i[1]), as.integer(i[length(i)]), PACKAGE='xts')) } else return(.Call('_do_subset_xts', x, as.integer(i), as.integer(j), drop, PACKAGE='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("fill_window_dups_rev", tmp, .index(x), PACKAGE = "xts") 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, window.xts <- function(x, index. = NULL, start = NULL, end = NULL, ...) { if(is.null(start) && is.null(end) && is.null(index.)) return(x) firstlast <- window_idx(x, index., start, end) # firstlast may be NULL .Call('_do_subset_xts', x, as.integer(firstlast), seq.int(1, ncol(x)), drop = FALSE, PACKAGE='xts') } # 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("binsearch", key, vec, start, PACKAGE='xts') } # Unit tests for the above code may be found in runit.xts.methods.R xts/R/start.R0000644000176200001440000000171413564762102012562 0ustar liggesusers# # 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/adj.time.R0000644000176200001440000000252613564762102013122 0ustar liggesusers# # 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 . 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, mon=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/timeBasedRange.R0000644000176200001440000000213613564762102014276 0ustar liggesusers# # 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 . `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/tclass.R0000644000176200001440000000513613564762102012720 0ustar liggesusers# # 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 . `convertIndex` <- function(x,value) { tclass(x) <- value x } tclass <- function(x, ...) { UseMethod('tclass') } tclass.xts <- function(x, ...) { tclass <- attr(attr(x, "index"), "tclass") # For xts objects created pre-0.10.3 if (is.null(tclass)) { warning("index does not have a ", sQuote("tclass"), " attribute") tclass <- attr(x, "tclass") if (is.null(tclass)) { tclass <- attr(x, ".indexCLASS") } if (is.null(tclass)) { warning("object does not have a ", sQuote("tclass"), " or ", sQuote(".indexCLASS"), " attribute") tclass <- "" } tclass } return(tclass) } `tclass<-` <- function(x,value) { UseMethod('tclass<-') } indexClass <- function(x) { .Deprecated("tclass", "xts") tclass(x) } `indexClass<-` <- function(x, value) { .Deprecated("tclass<-", "xts") `tclass<-`(x, value) } `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(any(value %in% .classesWithoutTZ)) { attr(attr(x,'index'), 'tzone') <- 'UTC' } attr(attr(x,'index'), 'tclass') <- value # Remove class attrs (object created before 0.10-3) attr(x, ".indexCLASS") <- NULL attr(x, "tclass") <- NULL x } xts/R/as.numeric.R0000644000176200001440000001106313564762102013467 0ustar liggesusers# # 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/axTicksByTime.R0000644000176200001440000000560013564762102014143 0ustar liggesusers# # 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 . 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/rollapply.xts.R0000644000176200001440000001461413564762102014263 0ustar liggesusers# # 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 # embedi <- function(n, k, by = 1, ascending = FALSE) { # n = no of time points, k = number of columns # by = increment. normally = 1 but if = b calc every b-th point # ascending If TRUE, points passed in ascending order else descending. # Note that embed(1:n, k) corresponds to embedi(n, k, by = 1, rev = TRUE) # e.g. embedi(10, 3) # s <- seq(1, n-k+1, by) # lens <- length(s) # cols <- 1:k # if(!ascending) cols <- rev(cols) # matrix(s + rep(cols, rep(lens,k))-1, lens) # } # 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))) { colnames(tmp) <- colnames(res) } 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("roll_sum", x, k, PACKAGE="xts") 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("roll_max", x, k, PACKAGE="xts") 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("roll_min", x, k, PACKAGE="xts") 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("roll_cov", x, y, k, sample, PACKAGE="xts") res } xts/R/Math.xts.R0000644000176200001440000000340013564762102013125 0ustar liggesusers# # 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/R/fillIndex.R0000644000176200001440000000176413564762102013350 0ustar liggesusers# # 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 . `fillIndex` <- function(x) { p <- periodicity(x) xx <- xts(matrix(rep(NA,NCOL(x)),nrow=1), seq(start(x),end(x),by=p$units)) xx[index(xx) %in% index(x)] <- x colnames(xx) <- colnames(x) xx } xts/R/data.frame.R0000644000176200001440000000327713564762102013435 0ustar liggesusers# # 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,...) } `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)) # 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='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/first.R0000644000176200001440000001022213564762102012546 0ustar liggesusers# # 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 . `first` <- function(x,...) { UseMethod("first") } `first.default` <- function(x,n=1,keep=FALSE,...) { 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 { sub <- seq.int(to = length(x), length.out = max(-n+1, 0L)) xx <- x[sub] if(keep) xx <- structure(xx,keep=x[1:(-n)]) 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 { sub <- seq.int(to = NROW(x), length.out = max(-n+1, 0L)) xx <- x[sub,,drop=FALSE] if(keep) xx <- structure(xx,keep=x[1:(-n),]) xx } } } `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 rpu <- np[length(np)] rpf <- ifelse(length(np) > 1, as.numeric(np[1]), 1) if(rpu == sp$unit) { 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$unit]]) { # 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 { 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) } } } 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(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 } } xts/R/ts.R0000644000176200001440000000773513564762102012064 0ustar liggesusers# # 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.ts2` <- function(x,...) { # attempt to provide a more robust reclass 'ts' method na.replace <- function(x) { na.removed <- attr(x,'na.action') if(class(na.removed) != 'omit') return() nrows <- NROW(x) ncols <- NCOL(x) xx <- vector('numeric',length=(nrows+length(na.removed))) xx[ na.removed,] <- NA xx[-na.removed] <- x xx } } `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') dn <- attr(x,'dimnames') if(!is.null(dim) && dim[2]==1) { attr(x,'dim') <- attr(x, 'dimnames') <- NULL } as.ts(x) } `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/matrix.R0000644000176200001440000000472413564762102012735 0ustar liggesusers# # 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,...) } `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/yearmon.R0000644000176200001440000000164413564762102013101 0ustar liggesusers# # 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.xts.yearmon <- function(x, ...) { xts(x=NULL, order.by=x) } as.xts.yearqtr <- function(x, ...) { xts(x=NULL, order.by=x) } xts/R/tzone.R0000644000176200001440000000575413564762102012574 0ustar liggesusers# # 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 . indexTZ <- function(x, ...) { .Deprecated("tzone", "xts") tzone(x, ...) } tzone <- function(x, ...) { UseMethod("tzone") } `indexTZ<-` <- function(x, value) { .Deprecated("tzone<-", "xts") `tzone<-`(x, value) } `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)) { tzone <- 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)) { warning("index does not have a ", sQuote("tzone"), " attribute") tzone <- attr(x, "tzone") if (is.null(tzone)) { tzone <- attr(x, ".indexTZ") } if (is.null(tzone)) { warning("object does not have a ", sQuote("tzone"), " or ", sQuote(".indexTZ"), " attribute") tzone <- "" } } return(tzone) } .classesWithoutTZ <- c("chron","dates","times","Date","yearmon","yearqtr") check.TZ <- function(x, ...) { #if( !getOption("xts_check_TZ", FALSE)) # return() check <- getOption("xts_check_TZ") if( !is.null(check) && !check) return() STZ <- as.character(Sys.getenv("TZ")) if(any(tclass(x) %in% .classesWithoutTZ)) { # 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 (!(tzone(x) %in% c("UTC","GMT"))) warning(paste0("index class is ", paste(class(index(x)), collapse=", "), ", which does not support timezones.\nExpected 'UTC' timezone", ", but tzone is ", sQuote(tzone(x))), call.=FALSE) else return() } if(!is.null(tzone(x)) && tzone(x) != "" && !identical(STZ, as.character(tzone(x)))) warning(paste("timezone of object (",tzone(x), ") is different than current timezone (",STZ,").",sep=""), call.=FALSE) } xts/R/bind.R0000644000176200001440000000606313564762102012343 0ustar liggesusers# # 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 . cbind.xts <- function(..., all=TRUE, fill=NA, suffixes=NULL) { # mc <- match.call(call=sys.call(sys.parent())) # mc[[1]] <- as.name("merge.xts") # eval(mc) merge.xts(..., all=all, fill=fill, suffixes=suffixes) } # # convert the call to a list to better manipulate it # mc <- as.list(match.call(call=sys.call(-1))) # # # remove deparse.level arg if called via cbind 'generic' # if(as.character(mc[[1]]) == "cbind") # mc <- mc[-2] # # # check if any default args are missing from the call, # # and add them to the call with the cbind defaults # if(missing(all)) mc <- c(mc,all=all) # if(missing(fill)) mc <- c(mc,fill=fill) # if(missing(suffixes)) mc <- c(mc,suffixes=suffixes) # # # replace the call to cbind.xts with merge.xts # mc[[1]] <- as.name('merge.xts') # # # convert the list into a call and evaluate it # mc <- as.call(mc) # eval(mc) #} # sc <- sys.call(sys.parent()) # mc <- gsub('cbind|cbind.xts','merge.xts',deparse(match.call(call=sc))) # return(eval(parse(text=mc))) # dots <- mc$... # length.args <- sum(.External("number_of_cols",...,PACKAGE="xts")) # if(is.null(suffixes)) # suffixes <- all.vars(match.call(call=sc), unique=FALSE)[1:length.args] # # if( length(suffixes) != length.args ) { # warning("length of suffixes and does not match number of merged objects") # suffixes <- rep(suffixes, length.out=length.args) # } # # merge.xts(..., all=all, fill=fill, suffixes=suffixes) # # dat <- list(...) # x <- dat[[1]]; dat <- dat[-1] # while( length(dat) > 0 ) { # y <- dat[[1]] # if( length(dat) > 0 ) # dat <- dat[-1] # x <- merge.xts(x, y, all=TRUE, fill=NA, suffixes=NULL, retclass="xts") # } # x #} `c.xts` <- function(...) { .External("rbindXts", dup=FALSE, ..., PACKAGE="xts") } rbind.xts <- function(..., deparse.level=1) { .External("rbindXts", dup=FALSE, ..., PACKAGE="xts") } `.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('do_rbind_xts',x,y,FALSE,PACKAGE="xts") } return(x) } xts/R/plot.R0000644000176200001440000014255213564762102012411 0ustar liggesusers# # 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)) # 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, ...){ 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] lines(xx$Env$xycoords$x,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 if(length(lty) < NCOL(x)) lty <- rep(lty, length.out = NCOL(x)) if(length(lwd) < NCOL(x)) lwd <- rep(lwd, length.out = NCOL(x)) if(length(col) < NCOL(x)) col <- rep(col, length.out = NCOL(x)) # ensure series only has index values in xdata subset xdataSubset <- xx$Env$xdata[xx$Env$xsubset] y <- merge(x, .xts(,.index(xdataSubset)), join = "right") xcoords <- xx$Env$xycoords$x for(i in NCOL(y):1) { lines(xcoords, y[,i], 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])) } chart.lines.expression <- function(...) { mc <- match.call() mc[[1]] <- quote(chart.lines) as.expression(mc) } isNullOrFalse <- function(x) { is.null(x) || identical(x, FALSE) } # Main plot.xts method. # author: Ross Bennett (adapted from Jeffrey Ryan's chart_Series) 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)), observation.based=FALSE, ylim=NULL, yaxis.same=TRUE, yaxis.left=TRUE, yaxis.right=TRUE, 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){ # 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)) # allow color and line attributes for each panel in a multi.panel plot if(length(lty) < ncol(x)) lty <- rep(lty, length.out = ncol(x)) if(length(lwd) < ncol(x)) lwd <- rep(lwd, length.out = ncol(x)) if(length(col) < ncol(x)) col <- rep(col, length.out = ncol(x)) 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, ylim=ylim, yaxis.same=yaxis.same, yaxis.left=yaxis.left, yaxis.right=yaxis.right, 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) 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) if(isTRUE(multi.panel)){ if(NCOL(x) == 1) cs$set_asp(3) else cs$set_asp(NCOL(x)) } else { cs$set_asp(3) } cs$Env$cex <- if (hasArg("cex")) eval.parent(plot.call$cex) else 0.6 cs$Env$mar <- if (hasArg("mar")) eval.parent(plot.call$mar) else c(3,2,0,2) cs$Env$theme$up.col <- up.col cs$Env$theme$dn.col <- dn.col # check for colorset or col argument # if col has a length of 1, replicate to NCOL(x) so we can keep it simple # and color each line by its index in col if(hasArg("colorset")) col <- eval.parent(plot.call$colorset) if(length(col) < ncol(x)) col <- rep(col, length.out = ncol(x)) cs$Env$theme$col <- col cs$Env$theme$rylab <- yaxis.right cs$Env$theme$lylab <- yaxis.left cs$Env$theme$bg <- bg cs$Env$theme$grid <- grid.col cs$Env$theme$grid2 <- grid2 cs$Env$theme$labels <- labels.col cs$Env$theme$srt <- if (hasArg("srt")) eval.parent(plot.call$srt) else 0 cs$Env$theme$las <- if (hasArg("las")) eval.parent(plot.call$las) else 0 cs$Env$theme$cex.axis <- if (hasArg("cex.axis")) eval.parent(plot.call$cex.axis) else 0.9 cs$Env$format.labels <- format.labels 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 # if lty or lwd has a length of 1, replicate to NCOL(x) so we can keep it # simple and draw each line with attributes by index if(length(lty) < ncol(x)) lty <- rep(lty, length.out = ncol(x)) if(length(lwd) < ncol(x)) lwd <- rep(lwd, length.out = ncol(x)) cs$Env$lty <- lty cs$Env$lwd <- lwd cs$Env$lend <- lend cs$Env$legend.loc <- legend.loc cs$Env$call_list <- list() cs$Env$call_list[[1]] <- plot.call cs$Env$observation.based <- observation.based # 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 # Set xlim using the raw returns data passed into function # xlim can be based on observations or time if(cs$Env$observation.based){ # observation based x-axis cs$Env$xycoords <- xy.coords(1:NROW(cs$Env$xdata[subset])) cs$set_xlim(c(1,NROW(cs$Env$xdata[subset]))) cs$Env$xstep <- 1 } else { # time based x-axis xycoords <- xy.coords(.index(cs$Env$xdata[cs$Env$xsubset]), cs$Env$xdata[cs$Env$xsubset][,1]) cs$Env$xycoords <- xycoords cs$Env$xlim <- range(xycoords$x, na.rm=TRUE) cs$Env$xstep <- diff(xycoords$x[1:2]) # I don't think I need this because I already set cs$Env$xlim cs$set_xlim(cs$Env$xlim) } # chart_Series uses fixed=FALSE and add_* uses fixed=TRUE, not sure why or # which is best. if(is.null(ylim)){ if(isTRUE(multi.panel)){ if(yaxis.same){ # set the ylim for the first panel based on all the data yrange <- range(cs$Env$xdata[subset], na.rm=TRUE) } else { # set the ylim for the first panel based on the first column yrange <- range(cs$Env$xdata[,1][subset], na.rm=TRUE) } } else { # set the ylim based on all the data if this is not a multi.panel plot yrange <- range(cs$Env$xdata[subset], na.rm=TRUE) } if(yrange[1L] == yrange[2L]) { if(yrange[1L] == 0) { yrange <- yrange + c(-1, 1) } else { yrange <- c(0.8, 1.2) * yrange[1L] } } cs$set_ylim(list(structure(yrange, fixed=TRUE))) cs$Env$constant_ylim <- range(cs$Env$xdata[subset], na.rm=TRUE) } else { # use the ylim arg passed in cs$set_ylim(list(structure(ylim, fixed=TRUE))) cs$Env$constant_ylim <- ylim } cs$set_frame(1,FALSE) # compute the x-axis ticks for the grid if(!isNullOrFalse(grid.ticks.on)) { cs$add(expression(atbt <- axTicksByTime(xdata[xsubset], ticks.on=grid.ticks.on), segments(xycoords$x[atbt], get_ylim()[[2]][1], xycoords$x[atbt], get_ylim()[[2]][2], col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)), clip=FALSE, expr=TRUE) } # Add frame for the chart "header" to display the name and start/end dates cs$add_frame(0,ylim=c(0,1),asp=0.5) cs$set_frame(1) # add observation level ticks on x-axis if < 400 obs. cs$add(expression(if(NROW(xdata[xsubset])<400) {axis(1,at=xycoords$x,labels=FALSE,col=theme$grid2,col.axis=theme$grid2,tcl=0.3)}),expr=TRUE) # major x-axis ticks and labels if(!isNullOrFalse(major.ticks)) { cs$add(expression(axt <- axTicksByTime(xdata[xsubset], ticks.on=major.ticks, format.labels=format.labels), axis(1, at=xycoords$x[axt], labels=names(axt), las=theme$las, lwd.ticks=1.5, mgp=c(3,1.5,0), tcl=-0.4, cex.axis=theme$cex.axis, col=theme$labels, col.axis=theme$labels)), expr=TRUE) } # minor x-axis ticks if(!isNullOrFalse(minor.ticks)) { cs$add(expression(axt <- axTicksByTime(xdata[xsubset], ticks.on=minor.ticks, format.labels=format.labels), axis(1, at=xycoords$x[axt], labels=FALSE, las=theme$las, lwd.ticks=0.75, mgp=c(3,1.5,0), tcl=-0.4, cex.axis=theme$cex.axis, col=theme$labels, col.axis=theme$labels)), expr=TRUE) } # add main title and date range of data text.exp <- c(expression(text(xlim[1],0.5,main,font=2,col=theme$labels,offset=0,cex=1.1,pos=4)), expression(text(xlim[2],0.5, paste(start(xdata[xsubset]),end(xdata[xsubset]),sep=" / "), col=theme$labels,adj=c(0,0),pos=2))) cs$add(text.exp, env=cs$Env, expr=TRUE) cs$set_frame(2) # add y-axis grid lines and labels exp <- expression(segments(xlim[1], y_grid_lines(get_ylim()[[2]]), xlim[2], y_grid_lines(get_ylim()[[2]]), col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)) if(yaxis.left){ exp <- c(exp, # left y-axis labels expression(text(xlim[1], y_grid_lines(get_ylim()[[2]]), noquote(format(y_grid_lines(get_ylim()[[2]]), justify="right")), col=theme$labels, srt=theme$srt, offset=1, pos=2, cex=theme$cex.axis, xpd=TRUE))) } if(yaxis.right){ exp <- c(exp, # right y-axis labels expression(text(xlim[2], y_grid_lines(get_ylim()[[2]]), noquote(format(y_grid_lines(get_ylim()[[2]]), justify="right")), col=theme$labels, srt=theme$srt, offset=1, pos=4, cex=theme$cex.axis, xpd=TRUE))) } cs$add(exp, env=cs$Env, expr=TRUE) # add main series cs$set_frame(2) if(isTRUE(multi.panel)){ # We need to plot the first "panel" here because the plot area is # set up based on the code above lenv <- cs$new_environment() lenv$xdata <- cs$Env$xdata[subset,1] lenv$label <- colnames(cs$Env$xdata[,1]) lenv$type <- cs$Env$type if(yaxis.same){ lenv$ylim <- cs$Env$constant_ylim } else { lenv$ylim <- range(cs$Env$xdata[subset,1], na.rm=TRUE) } exp <- quote(chart.lines(xdata, type=type, lty=lty, lwd=lwd, lend=lend, col=theme$col, up.col=theme$up.col, dn.col=theme$dn.col, legend.loc=legend.loc)) exp <- as.expression(add.par.from.dots(exp, ...)) # Add expression for the main plot cs$add(exp, env=lenv, expr=TRUE) text.exp <- expression(text(x=xycoords$x[2], y=ylim[2]*0.9, labels=label, col=theme$labels, adj=c(0,0),cex=1,offset=0,pos=4)) cs$add(text.exp,env=lenv,expr=TRUE) if(NCOL(cs$Env$xdata) > 1){ for(i in 2:NCOL(cs$Env$xdata)){ # create a local environment lenv <- cs$new_environment() lenv$xdata <- cs$Env$xdata[subset,i] lenv$label <- cs$Env$column_names[i] if(yaxis.same){ lenv$ylim <- cs$Env$constant_ylim } else { yrange <- range(cs$Env$xdata[subset,i], na.rm=TRUE) if(all(yrange == 0)) yrange <- yrange + c(-1,1) lenv$ylim <- yrange } lenv$type <- cs$Env$type # 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] # Add a small frame cs$add_frame(ylim=c(0,1),asp=0.25) cs$next_frame() text.exp <- expression(text(x=xlim[1], y=0.5, labels="", adj=c(0,0),cex=0.9,offset=0,pos=4)) cs$add(text.exp, env=lenv, expr=TRUE) # Add the frame for the sub-plots cs$add_frame(ylim=lenv$ylim, asp=NCOL(cs$Env$xdata), fixed=TRUE) cs$next_frame() exp <- quote(chart.lines(xdata[xsubset], type=type, lty=lty, lwd=lwd, lend=lend, col=col, up.col=theme$up.col, dn.col=theme$dn.col, legend.loc=legend.loc)) exp <- as.expression(add.par.from.dots(exp, ...)) # NOTE 'exp' was defined earlier as chart.lines exp <- c(exp, # y-axis grid lines expression(segments(xlim[1], y_grid_lines(ylim), xlim[2], y_grid_lines(ylim), col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty)), # x-axis grid lines expression(x_grid_lines(xdata[xsubset], grid.ticks.on, ylim))) if(yaxis.left){ exp <- c(exp, # y-axis labels/boxes expression(text(xlim[1], y_grid_lines(ylim), noquote(format(y_grid_lines(ylim),justify="right")), col=theme$labels, srt=theme$srt, offset=1, pos=2, cex=theme$cex.axis, xpd=TRUE))) } if(yaxis.right){ exp <- c(exp, expression(text(xlim[2], y_grid_lines(ylim), noquote(format(y_grid_lines(ylim),justify="right")), col=theme$labels, srt=theme$srt, offset=1, pos=4, cex=theme$cex.axis, xpd=TRUE))) } cs$add(exp,env=lenv,expr=TRUE,no.update=TRUE) text.exp <- expression(text(x=xycoords$x[2], y=ylim[2]*0.9, labels=label, col=theme$labels, adj=c(0,0),cex=1,offset=0,pos=4)) cs$add(text.exp,env=lenv,expr=TRUE) } } } else { if(type == "h" & NCOL(x) > 1) warning("only the univariate series will be plotted") exp <- quote(chart.lines(xdata[xsubset], type=type, lty=lty, lwd=lwd, lend=lend, col=theme$col, up.col=theme$up.col, dn.col=theme$dn.col, legend.loc=legend.loc)) exp <- as.expression(add.par.from.dots(exp, ...)) cs$add(exp, expr=TRUE) 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 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 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$main <- main lenv$plot_lines <- function(x, ta, on, type, col, lty, lwd, pch, ...){ xdata <- x$Env$xdata xsubset <- x$Env$xsubset xDataSubset <- xdata[xsubset] if(all(is.na(on))){ # Add x-axis grid lines x$Env$x_grid_lines(xDataSubset, x$Env$grid.ticks.on, par("usr")[3:4]) } # we can add points that are not necessarily at the points # on the main series if(xsubset == "") { subset.range <- xsubset } else { subset.range <- paste(start(xDataSubset), end(xDataSubset),sep="/") } ta.y <- merge(ta, .xts(,.index(xDataSubset), tzone=tzone(xdata)))[subset.range] 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)) plot_object$add_call(match.call()) xdata <- plot_object$Env$xdata xsubset <- plot_object$Env$xsubset no.update <- FALSE 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 the frame for drawdowns info plot_object$add_frame(ylim=c(0,1),asp=0.25) plot_object$next_frame() text.exp <- expression(text(x=xlim[1], y=0.3, labels=main, col=1,adj=c(0,0),cex=0.9,offset=0,pos=4)) plot_object$add(text.exp, env=lenv, expr=TRUE) # add frame for the data plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) plot_object$next_frame() # NOTE 'exp' was defined earlier as chart.lines exp <- c(exp, # y-axis grid lines expression(segments(xlim[1], y_grid_lines(ylim), xlim[2], y_grid_lines(ylim), col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty))) if(plot_object$Env$theme$lylab){ exp <- c(exp, # y-axis labels/boxes expression(text(xlim[1]-xstep*2/3-max(strwidth(y_grid_lines(ylim))), y_grid_lines(ylim), noquote(format(y_grid_lines(ylim),justify="right")), col=theme$labels, srt=theme$srt, offset=0, pos=4, cex=theme$cex.axis, xpd=TRUE))) } if(plot_object$Env$theme$rylab){ exp <- c(exp, expression(text(xlim[2]+xstep*2/3, y_grid_lines(ylim), noquote(format(y_grid_lines(ylim),justify="right")), col=theme$labels, srt=theme$srt, offset=0, pos=4, cex=theme$cex.axis, xpd=TRUE))) } plot_object$add(exp,env=lenv,expr=TRUE,no.update=TRUE) } else { for(i in 1:length(on)) { plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable? plot_object$add(exp,env=lenv,expr=TRUE,no.update=no.update) } } plot_object } # Add time series of lines to an existing xts plot # author: Ross Bennett 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_panel() 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 points.xts <- function(x, ..., main="", on=0, col=NULL, pch=1){ if(!is.na(on[1])) if(on[1] == 0) on[1] <- current_panel() addSeries(x, ...=..., main=main, on=on, type="p", col=col, pch=pch) } # Add vertical lines to an existing xts plot # author: Ross Bennett addEventLines <- function(events, main="", on=0, lty=1, lwd=1, col=1, ...){ events <- try.xts(events) if(!is.na(on[1])) if(on[1] == 0) on[1] <- current_panel() 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)) } plot_object <- current.xts_chob() lenv <- plot_object$new_environment() lenv$main <- main lenv$plot_event_lines <- function(x, events, on, lty, lwd, col, ...){ xdata <- x$Env$xdata xsubset <- x$Env$xsubset if(all(is.na(on))){ # Add x-axis grid lines x$Env$x_grid_lines(xdata[xsubset], x$Env$grid.ticks.on, par("usr")[3:4]) } ypos <- x$Env$ylim[[2*on]][2]*0.995 # we can add points that are not necessarily at the points on the main series subset.range <- paste(start(xdata[xsubset]), end(xdata[xsubset]),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.x <- as.numeric(na.approx(ta.adj[,1], rule=2) ) 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$Env$xycoords$x[event.ind], col=col, lty=lty, lwd=lwd) text(x=x$Env$xycoords$x[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)) plot_object$add_call(match.call()) if(is.na(on[1])){ xdata <- plot_object$Env$xdata xsubset <- plot_object$Env$xsubset no.update <- FALSE lenv$xdata <- xdata ylim <- range(xdata[xsubset], na.rm=TRUE) lenv$ylim <- ylim # add the frame for drawdowns info plot_object$add_frame(ylim=c(0,1),asp=0.25) plot_object$next_frame() text.exp <- expression(text(x=xlim[1], y=0.3, labels=main, col=1,adj=c(0,0),cex=0.9,offset=0,pos=4)) plot_object$add(text.exp, env=lenv, expr=TRUE) # add frame for the data plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) plot_object$next_frame() # NOTE 'exp' was defined earlier as chart.lines exp <- c(exp, # y-axis grid lines expression(segments(xlim[1], y_grid_lines(ylim), xlim[2], y_grid_lines(ylim), col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty))) if(plot_object$Env$theme$lylab){ exp <- c(exp, # y-axis labels/boxes expression(text(xlim[1]-xstep*2/3-max(strwidth(y_grid_lines(ylim))), y_grid_lines(ylim), noquote(format(y_grid_lines(ylim),justify="right")), col=theme$labels, srt=theme$srt, offset=0, pos=4, cex=theme$cex.axis, xpd=TRUE))) } if(plot_object$Env$theme$rylab){ exp <- c(exp, expression(text(xlim[2]+xstep*2/3, y_grid_lines(ylim), noquote(format(y_grid_lines(ylim),justify="right")), col=theme$labels, srt=theme$srt, offset=0, pos=4, cex=theme$cex.axis, xpd=TRUE))) } plot_object$add(exp,env=lenv,expr=TRUE,no.update=TRUE) } else { for(i in 1:length(on)) { ind <- on[i] no.update <- FALSE plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable? plot_object$add(exp,env=lenv,expr=TRUE,no.update=no.update) } } plot_object } # Add legend to an existing xts plot # author: Ross Bennett addLegend <- function(legend.loc="topright", legend.names=NULL, col=NULL, ncol=1, on=0, ...){ if(!is.na(on[1])) if(on[1] == 0) on[1] <- current_panel() plot_object <- current.xts_chob() 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 { yrange <- x$Env$ylim[[2*on]] } # this just gets the data of the main plot # TODO: get the data of frame[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, ...) } # store the call plot_object$add_call(match.call()) # 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 frame for spacing plot_object$add_frame(ylim=c(0,1),asp=0.25) plot_object$next_frame() text.exp <- expression(text(x=xlim[1], y=0.3, labels=main, col=theme$labels,adj=c(0,0),cex=0.9,offset=0,pos=4)) plot_object$add(text.exp, env=lenv, expr=TRUE) # add frame for the legend panel plot_object$add_frame(ylim=c(0,1),asp=0.8,fixed=TRUE) plot_object$next_frame() # add plot_legend expression plot_object$add(exp,env=lenv,expr=TRUE,no.update=TRUE) } else { for(i in 1:length(on)) { ind <- on[i] no.update <- FALSE plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable? plot_object$add(exp,env=lenv,expr=TRUE,no.update=no.update) } } 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 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$main <- main lenv$plot_lines <- function(x, ta, on, col, ...){ xdata <- x$Env$xdata xsubset <- x$Env$xsubset if(is.null(col)) col <- x$Env$theme$col if(all(is.na(on))){ # Add x-axis grid lines x$Env$x_grid_lines(xdata[xsubset], x$Env$grid.ticks.on, par("usr")[3:4]) } # we can add points that are not necessarily at the points # on the main series subset.range <- paste(start(xdata[xsubset]), end(xdata[xsubset]),sep="/") ta.adj <- merge(n=.xts(1:NROW(xdata[xsubset]), .index(xdata[xsubset]), tzone=tzone(xdata)),ta)[subset.range] ta.x <- as.numeric(na.approx(ta.adj[,1], rule=2) ) # NAs in the coordinates break the polygon which is not the behavior we want ta.y <- na.omit(ta.adj[,-1]) n <- NROW(ta.y) # x coordinates xx <- .index(ta.y)[c(1,1:n,n:1)] # 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)) plot_object$add_call(match.call()) xdata <- plot_object$Env$xdata xsubset <- plot_object$Env$xsubset no.update <- FALSE 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])){ plot_object$add_frame(ylim=c(0,1),asp=0.25) plot_object$next_frame() text.exp <- expression(text(x=xlim[1], y=0.3, labels=main, col=1,adj=c(0,0),cex=0.9,offset=0,pos=4)) plot_object$add(text.exp, env=lenv, expr=TRUE) # add frame for the data plot_object$add_frame(ylim=ylim,asp=1,fixed=TRUE) plot_object$next_frame() # NOTE 'exp' was defined earlier as plot_lines exp <- c(exp, # y-axis grid lines expression(segments(xlim[1], y_grid_lines(ylim), xlim[2], y_grid_lines(ylim), col=theme$grid, lwd=grid.ticks.lwd, lty=grid.ticks.lty))) if(plot_object$Env$theme$lylab){ exp <- c(exp, # y-axis labels/boxes expression(text(xlim[1], y_grid_lines(ylim), noquote(format(y_grid_lines(ylim),justify="right")), col=theme$labels, srt=theme$srt, offset=1, pos=2, cex=theme$cex.axis, xpd=TRUE))) } if(plot_object$Env$theme$rylab){ exp <- c(exp, expression(text(xlim[2], y_grid_lines(ylim), noquote(format(y_grid_lines(ylim),justify="right")), col=theme$labels, srt=theme$srt, offset=1, pos=4, cex=theme$cex.axis, xpd=TRUE))) } plot_object$add(exp,env=lenv,expr=TRUE,no.update=TRUE) } else { for(i in 1:length(on)) { plot_object$set_frame(2*on[i]) # this is defaulting to using headers, should it be optionable? plot_object$add(exp,env=lenv,expr=TRUE,no.update=no.update) } } plot_object }# polygon # R/replot.R in quantmod with only minor edits to change class name to # replot_xts and use the .plotxtsEnv instead of the .plotEnv in quantmod new.replot_xts <- function(frame=1,asp=1,xlim=c(1,10),ylim=list(structure(c(1,10),fixed=FALSE))) { # global variables Env <- new.env() Env$frame <- frame Env$asp <- asp Env$xlim <- xlim Env$ylim <- ylim Env$pad1 <- -0 # bottom padding per frame Env$pad3 <- 0 # top padding per frame if(length(asp) != length(ylim)) stop("'ylim' and 'asp' must be the same length") # setters set_frame <- function(frame,clip=TRUE) { Env$frame <<- frame; set_window(clip); # change actual window } set_asp <- function(asp) { Env$asp <<- asp } set_xlim <- function(xlim) { Env$xlim <<- xlim } set_ylim <- function(ylim) { Env$ylim <<- ylim } set_pad <- function(pad) { Env$pad1 <<- pad[1]; Env$pad3 <<- pad[2] } reset_ylim <- function() { ylim <- get_ylim() ylim <- rep(list(c(Inf,-Inf)),length(ylim)) lapply(Env$actions, function(x) { frame <- attr(x, "frame") if(frame > 0) { lenv <- attr(x,"env") if(is.list(lenv)) lenv <- lenv[[1]] ylim[[frame]][1] <<- min(ylim[[frame]][1],range(na.omit(lenv$xdata[Env$xsubset]))[1],na.rm=TRUE) ylim[[frame]][2] <<- max(ylim[[frame]][2],range(na.omit(lenv$xdata[Env$xsubset]))[2],na.rm=TRUE) } }) # reset all ylim values, by looking for range(env[[1]]$xdata) # xdata should be either coming from Env or if lenv lenv set_ylim(ylim) } # getters get_frame <- function(frame) { Env$frame } get_asp <- function(asp) { Env$asp } get_xlim <- function(xlim) { Env$xlim } get_ylim <- function(ylim) { Env$ylim } get_pad <- function() c(Env$pad1,Env$pad3) # scale ylim based on current frame, and asp values scale_ranges <- function(frame, asp, ranges) { asp/asp[frame] * abs(diff(ranges[[frame]])) } # set_window prepares window for drawing set_window <- function(clip=TRUE,set=TRUE) { frame <- Env$frame frame <- abs(frame) asp <- Env$asp xlim <- Env$xlim ylim <- lapply(Env$ylim, function(x) structure(x + (diff(x) * c(Env$pad1, Env$pad3)),fixed=attr(x,"fixed"))) sr <- scale_ranges(frame, asp, ylim) if(frame == 1) { win <- list(xlim, c((ylim[[frame]][1] - sum(sr[-1])), ylim[[frame]][2])) } else if(frame == length(ylim)) { win <- list(xlim, c(ylim[[frame]][1], ylim[[frame]][2] + sum(sr[-length(sr)]))) } else { win <- list(xlim, c(ylim[[frame]][1] - sum(sr[-(1:frame)]), ylim[[frame]][2] + sum(sr[-(frame:length(sr))]))) } if(!set) return(win) do.call("plot.window",win) if(clip) clip(par("usr")[1],par("usr")[2],ylim[[frame]][1],ylim[[frame]][2]) } get_actions <- function(frame) { actions <- NULL for(i in 1:length(Env$actions)) { if(abs(attr(Env$actions[[i]],"frame"))==frame) actions <- c(actions, Env$actions[i]) } actions } # add_frame: # append a plot frame to the plot window add_frame <- function(after, ylim=c(0,0), asp=0, fixed=FALSE) { if(missing(after)) after <- max(abs(sapply(Env$actions, function(x) attr(x,"frame")))) for(i in 1:length(Env$actions)) { cframe <- attr(Env$actions[[i]],"frame") if(cframe > 0 && cframe > after) attr(Env$actions[[i]], "frame") <- cframe+1L if(cframe < 0 && cframe < -after) attr(Env$actions[[i]], "frame") <- cframe-1L } Env$ylim <- append(Env$ylim,list(structure(ylim,fixed=fixed)),after) Env$asp <- append(Env$asp,asp,after) } update_frames <- function(headers=TRUE) { # use subset code here, without the subset part. from_by <- ifelse(headers,2,1) ylim <- get_ylim() for(y in seq(from_by,length(ylim),by=from_by)) { if(!attr(ylim[[y]],'fixed')) ylim[[y]] <- structure(c(Inf,-Inf),fixed=FALSE) } lapply(Env$actions, function(x) { if(!is.null(attr(x,"no.update")) && attr(x, "no.update")) return(NULL) frame <- abs(attr(x, "frame")) fixed <- attr(ylim[[frame]],'fixed') if(frame %% from_by == 0 && !fixed) { lenv <- attr(x,"env") if(is.list(lenv)) lenv <- lenv[[1]] dat.range <- range(na.omit(lenv$xdata[Env$xsubset])) min.tmp <- min(ylim[[frame]][1],dat.range,na.rm=TRUE) max.tmp <- max(ylim[[frame]][2],dat.range,na.rm=TRUE) ylim[[frame]] <<- structure(c(min.tmp,max.tmp),fixed=fixed) } }) # reset all ylim values, by looking for range(env[[1]]$xdata) # xdata should be either coming from Env or if lenv, lenv set_ylim(ylim) } remove_frame <- function(frame) { rm.frames <- NULL max.frame <- max(abs(sapply(Env$actions, function(x) attr(x,"frame")))) for(i in 1:length(Env$actions)) { cframe <- attr(Env$actions[[i]],"frame") if(abs(attr(Env$actions[[i]],"frame"))==frame) rm.frames <- c(rm.frames, i) if(cframe > 0 && cframe > frame) { attr(Env$actions[[i]], "frame") <- cframe-1L } if(cframe < 0 && cframe < -frame) { attr(Env$actions[[i]], "frame") <- cframe+1L } } if(frame > max.frame) { Env$frame <- max.frame } else Env$frame <- max.frame-1 Env$ylim <- Env$ylim[-frame] Env$asp <- Env$asp[-frame] if(!is.null(rm.frames)) Env$actions <- Env$actions[-rm.frames] } next_frame <- function() { set_frame(max(abs(sapply(Env$actions,function(x) attr(x,"frame"))))+1L) } move_frame <- function() {} # actions Env$actions <- list() # aplot add <- replot <- function(x,env=Env,expr=FALSE,clip=TRUE,...) { if(!expr) { x <- match.call()$x } a <- structure(x,frame=Env$frame,clip=clip,env=env,...) Env$actions[[length(Env$actions)+1]] <<- a } # subset function subset <- function(x="") { Env$xsubset <<- x set_xlim(range(Env$xycoords$x, na.rm=TRUE)) ylim <- get_ylim() for(y in seq(2,length(ylim),by=2)) { if(!attr(ylim[[y]],'fixed')) ylim[[y]] <- structure(c(Inf,-Inf),fixed=FALSE) } lapply(Env$actions, function(x) { frame <- abs(attr(x, "frame")) fixed <- attr(ylim[[frame]],'fixed') if(frame %% 2 == 0 && !fixed) { lenv <- attr(x,"env") if(is.list(lenv)) lenv <- lenv[[1]] yrange <- range(lenv$xdata[Env$xsubset], na.rm=TRUE) if(all(yrange == 0)) yrange <- yrange + c(-1,1) min.tmp <- min(ylim[[frame]][1],yrange[1],na.rm=TRUE) max.tmp <- max(ylim[[frame]][2],yrange[2],na.rm=TRUE) ylim[[frame]] <<- structure(c(min.tmp,max.tmp),fixed=fixed) } }) # reset all ylim values, by looking for range(env[[1]]$xdata) # xdata should be either coming from Env or if lenv, lenv set_ylim(ylim) } # calls add_call <- function(call.) { stopifnot(is.call(call.)) ncalls <- length(Env$call_list) Env$call_list[[ncalls+1]] <- call. } # return replot_env <- new.env() class(replot_env) <- c("replot_xts","environment") replot_env$Env <- Env replot_env$set_window <- set_window replot_env$add <- add replot_env$replot <- replot replot_env$get_actions <- get_actions replot_env$subset <- subset replot_env$update_frames <- update_frames replot_env$set_frame <- set_frame replot_env$get_frame <- get_frame replot_env$next_frame <- next_frame replot_env$add_frame <- add_frame replot_env$remove_frame <- remove_frame replot_env$set_asp <- set_asp replot_env$get_asp <- get_asp replot_env$set_xlim <- set_xlim replot_env$get_xlim <- get_xlim replot_env$reset_ylim <- reset_ylim replot_env$set_ylim <- set_ylim replot_env$get_ylim <- get_ylim replot_env$set_pad <- set_pad replot_env$add_call <- add_call replot_env$new_environment <- function() { new.env(TRUE, Env) } # function to plot the y-axis grid lines replot_env$Env$y_grid_lines <- function(ylim) { p <- pretty(ylim,5) p[p > ylim[1] & p < ylim[2]] } # 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" atbt <- axTicksByTime(x, ticks.on = ticks.on) segments(Env$xycoords$x[atbt], ylim[1L], Env$xycoords$x[atbt], ylim[2L], col = Env$theme$grid, lwd = Env$grid.ticks.lwd, lty = Env$grid.ticks.lty) } } return(replot_env) } str.replot_xts <- function(x, ...) { print(str(unclass(x))) } 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") # plot negative (underlay) actions last.frame <- x$get_frame() x$update_frames() lapply(x$Env$actions, function(aob) { if(attr(aob,"frame") < 0) { x$set_frame(attr(aob,"frame"),attr(aob,"clip")) env <- attr(aob,"env") if(is.list(env)) { # if env is c(env, Env), convert to list env <- unlist(lapply(env, function(x) eapply(x, eval)),recursive=FALSE) } eval(aob, env) } } ) # plot positive (overlay) actions lapply(x$Env$actions, function(aob) { if(attr(aob,"frame") > 0) { x$set_frame(attr(aob,"frame"),attr(aob,"clip")) env <- attr(aob,"env") if(is.list(env)) { env <- unlist(lapply(env, function(x) eapply(x, eval)),recursive=FALSE) } eval(aob, env) } } ) x$set_frame(abs(last.frame),clip=FALSE) do.call("clip", as.list(usr)) # reset clipping region # reset par par(xpd = oxpd$xpd, cex = ocex$cex, mar = omar$mar, bg = obg$bg) invisible(x$Env$actions) } actions <- function(obj) obj$Env$actions chart_actions <- function() actions(current.xts_chob()) current_panel <- function() { act <- chart_actions() # we need to divide by 2 because there are 2 frames per panel attr(act[[length(act)]], "frame") / 2 } xts/R/Ops.xts.R0000644000176200001440000000410213564762102012775 0ustar liggesusers# # 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) { CLASS <- .Class 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)) e2 <- merge.xts(e2, e1, all=FALSE, retclass=FALSE, retside=c(TRUE,FALSE)) e1 <- tmp.e1 .Class <- "matrix" NextMethod(.Generic) } } if(.Generic %in% c("+","-","*","/","^","%%","%/%")) { #.Call('add_xts_class', e) .Call('add_class', e, CLASS, PACKAGE="xts") } if(length(e)==0) { if(is.xts(e1)) { idx <- .index(e1) } else { idx <- .index(e2) } idx[] <- idx[0] attr(e,'index') <- idx } if(is.null(attr(e,'index'))) { if(is.xts(e1)) { e <- .xts(e, .index(e1)) } else { e <- .xts(e, .index(e2)) } if(is.null(dim(e1)) && is.null(dim(e2))) dim(e) <- NULL } if(!is.null(dimnames(e)[[1L]])) { if(is.null(dimnames(e)[[2L]])) { attr(e, "dimnames") <- NULL } else { dimnames(e)[[1]] <- list(NULL) } } attr(e, "names") <- NULL e } xts/R/str.R0000644000176200001440000000266313564762102012241 0ustar liggesusers# # 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,...) { if(length(object) == 0) { cat("An 'xts' object of zero-width\n") } else { cat(paste("An",sQuote('xts'),"object on", #index(first(object)),"to",index(last(object)), .makeISO8601(object), "containing:\n")) cat(paste(" Data:")) str(coredata(object)) cat(paste(" Indexed by objects of class: ")) cat(paste('[',paste(tclass(object),collapse=','),'] ',sep='')) cat(paste("TZ: ", tzone(object), "\n", sep="")) if(!is.null(CLASS(object))) cat(paste(" Original class: '",CLASS(object),"' ",sep=""),"\n") cat(paste(" xts Attributes: "),"\n") str(xtsAttributes(object),...) } } xts/R/xtsible.R0000644000176200001440000000353413564762102013101 0ustar liggesusers# # 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 . xtsible <- function(x) { if(inherits(try(as.xts(x),silent=TRUE),'try-error')) { FALSE } else TRUE } 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) } } .merge.xts.scalar <- function(x, length.out, ...) { 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") } 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) } xts/R/isOrdered.R0000644000176200001440000000223713564762102013346 0ustar liggesusers# # 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 . `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('do_is_ordered', x = x, increasing = as.logical(increasing), strictly = as.logical(strictly), PACKAGE='xts') } xts/R/tformat.R0000644000176200001440000000307413564762102013102 0ustar liggesusers# # 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 . `tformat` <- function(x) { UseMethod('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 } `indexFormat` <- function(x) { .Deprecated("tformat", "xts") tformat(x) } `indexFormat<-` <- function(x, value) { .Deprecated("tformat<-", "xts") `tformat<-`(x, value) } xts/R/lag.xts.R0000644000176200001440000001002613564762102013001 0ustar liggesusers# # 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 . `Lag.xts` <- function(x, k=1, na.action=na.pass, ...) { x <- try.xts(x, error=FALSE) if(!is.xts(x)) x <- as.matrix(x) xx <-sapply(k, function(k) { apply(x, 2, function(x) { if(k==0) return(as.matrix(x)) as.matrix(c(rep(NA, k), x[-((length(x) - k + 1):length(x))])) } )} ) xx <- matrix(as.numeric(xx),nrow=NROW(x)) colnames(xx) <- c(paste(colnames(x)[(rep(1:NCOL(x),length(k)))], 'lag', rep(k, each=NCOL(x)), sep = ".")) as.function(na.action)(reclass(xx,x)) } `Next.xts` <- function(x, k=1, na.action=na.pass, ...) { x <- try.xts(x, error=FALSE) if(!is.xts(x)) x <- as.matrix(x) xx <-sapply(k, function(k) { apply(x, 2, function(x) { if(k==0) return(as.matrix(x)) as.matrix(c(x[-(1:k)],rep(NA, k))) } )} ) xx <- matrix(as.numeric(xx),nrow=NROW(x)) colnames(xx) <- c(paste(colnames(x)[(rep(1:NCOL(x),length(k)))], 'next', rep(k, each=NCOL(x)), sep = ".")) as.function(na.action)(reclass(xx,x)) } 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('lag_xts', x, k, na.pad, PACKAGE='xts') } lagts.xts <- function(x, k=1, na.pad=TRUE, ...) { 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('lag_xts', x, k, na.pad, PACKAGE='xts') } 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/dimnames.R0000644000176200001440000000224213564762102013217 0ustar liggesusers# # 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.xts` <- function(x) { #list(NULL, colnames(unclass(x))) .Call("dimnames_zoo",x,PACKAGE="xts"); #list(as.character(index(x)), colnames(unclass(x))) } `dimnames<-.xts` <- function(x, value) { .Call("xts_set_dimnames", x, value, PACKAGE = "xts") } xts/R/tis.R0000644000176200001440000000203413564762102012220 0ustar liggesusers# # 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 support package:tis as.POSIXct.tis <- function(x, offset=1, tz="", ...) as.numeric(.POSIXct(x,tz)) as.xts.tis <- function(x, offset=1, ...) { .xts(unclass(x), as.numeric(as.POSIXct.tis(x,offset)), ...) } re.tis <- function() {} xts/R/fts.R0000644000176200001440000000265613564762102012227 0ustar liggesusers# # 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.xts.fts` <- function(x, ..., .RECLASS=FALSE) { dates <- .index(x) # fts uses POSIXct attributes(dates) <- NULL if(.RECLASS) { .xts(unclass(x), dates, .CLASS="fts", ...) } else { .xts(unclass(x), dates, ...) } } `as.fts.xts` <- function(x) { if(!requireNamespace('fts', quietly=TRUE)) fts <- function(...) message("package 'fts' is required") ix <- .index(x) attributes(ix) <- NULL fts::fts(ix, coredata(x)) } re.fts <- function(x, ...) { if(!requireNamespace('fts', quietly=TRUE)) fts <- function(...) message("package 'fts' is required") ix <- .index(x) attributes(ix) <- NULL fts::fts(ix, coredata(x)) } xts/R/endpoints.R0000644000176200001440000001036113564762102013426 0ustar liggesusers# # 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 . endpoints <- function(x,on='months',k=1) { if(timeBased(x)) { NR <- length(x) x <- xts(, order.by=x) } else NR <- NROW(x) addlast <- TRUE # remove automatic NR last value if(!is.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)) 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[seq(1,length(ep),k)] else ep }, "months" = { ixmon <- posixltindex$year * 100L + 190000L + posixltindex$mon ep <- .Call("endpoints", ixmon, 1L, 1L, addlast, PACKAGE='xts') if(k > 1) ep[seq(1,length(ep),k)] else ep }, "weeks" = { .Call("endpoints", .index(x)+3L*86400L, 604800L, k, addlast, PACKAGE='xts') }, "days" = { ixyday <- posixltindex$year * 1000L + 1900000L + posixltindex$yday .Call("endpoints", ixyday, 1L, k, addlast, PACKAGE='xts') }, # non-date slicing should be indifferent to TZ and DST, so use math instead "hours" = { .Call("endpoints", .index(x), 3600L, k, addlast, PACKAGE='xts') }, "minutes" = { .Call("endpoints", .index(x), 60L, k, addlast, PACKAGE='xts') }, "seconds" = { .Call("endpoints", .index(x), 1L, k, addlast, PACKAGE='xts') }, "ms" = , "milliseconds" = { sec2ms <- .index(x) * 1e3 .Call("endpoints", sec2ms, 1L, k, addlast, PACKAGE='xts') }, "us" = , "microseconds" = { sec2us <- .index(x) * 1e6 .Call("endpoints", sec2us, 1L, k, addlast, PACKAGE='xts') } ) } `startof` <- function(x,by='months', k=1) { ep <- endpoints(x,on=by, k=k) (ep+1)[-length(ep)] } `endof` <- function(x,by='months', k=1) { endpoints(x,on=by, k=k)[-1] } `firstof` <- function(year=1970,month=1,day=1,hour=0,min=0,sec=0,tz="") { ISOdatetime(year,month,day,hour,min,sec,tz) } lastof <- function (year = 1970, month = 12, day = 31, hour = 23, min = 59, sec = 59, subsec=.99999, tz = "") { if(!missing(sec) && sec %% 1 != 0) subsec <- 0 sec <- ifelse(year < 1970, sec, sec+subsec) # <1970 asPOSIXct bug workaround #sec <- sec + subsec mon.lengths <- c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) if (missing(day)) { day <- ifelse(month %in% 2, ifelse(((year%%4 %in% 0 & !year%%100 %in% 0) | (year%%400 %in% 0)), 29, 28), mon.lengths[month]) } # strptime has an issue (bug?) which returns NA when passed # 1969-12-31-23-59-59; pass 58.9 secs instead. 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)) && Sys.getenv("TZ") %in% c("", "GMT", "UTC")) sec <- sec-1 ISOdatetime(year, month, day, hour, min, sec, tz) } xts/R/na.R0000644000176200001440000000623013564762102012021 0ustar liggesusers# # 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('na_omit_xts', object, PACKAGE="xts") 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('na_omit_xts', object, PACKAGE="xts") 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) } na.locf.xts <- function(object, na.rm=FALSE, fromLast=FALSE, maxgap=Inf, ...) { stopifnot(is.xts(object)) maxgap <- min(maxgap, NROW(object)) if(length(object) == 0) return(object) if(hasArg("x") || hasArg("xout")) return(NextMethod()) x <- .Call("na_locf", object, fromLast, maxgap, Inf, PACKAGE="xts") if(na.rm) { return(structure(na.omit(x),na.action=NULL)) } else x } xts/R/period.apply.R0000644000176200001440000000535613564762102014041 0ustar liggesusers# # 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 . `period.apply` <- function(x, INDEX, FUN, ...) { 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]) } `period.apply.original` <- function (x, INDEX, FUN, ...) { x <- use.xts(x,error=FALSE) if(!is.xts(x)) { FUN <- match.fun(FUN) xx <- sapply(1:(length(INDEX) - 1), function(y) { FUN(x[(INDEX[y] + 1):INDEX[y + 1]], ...) }) } else { FUN <- match.fun(FUN) new.index <- index(x)[INDEX] xx <- sapply(1:(length(INDEX) - 1), function(y) { FUN(x[(INDEX[y] + 1):INDEX[y + 1]], ...) }) xx <- xts(xx,new.index) CLASS(xx) <- CLASS(x) xtsAttributes(xx) <- xtsAttributes(x) xx <- reclass(xx) } xx } `apply.daily` <- function(x,FUN, ...) { ep <- endpoints(x,'days') period.apply(x,ep,FUN, ...) } `apply.weekly` <- function(x,FUN, ...) { ep <- endpoints(x,'weeks') period.apply(x,ep,FUN, ...) } `apply.monthly` <- function(x,FUN, ...) { ep <- endpoints(x,'months') period.apply(x,ep,FUN, ...) } `apply.quarterly` <- function(x,FUN, ...) { ep <- endpoints(x,'quarters') period.apply(x,ep,FUN, ...) } `apply.yearly` <- function(x,FUN, ...) { ep <- endpoints(x,'years') period.apply(x,ep,FUN, ...) } period_apply <- function(x, INDEX, FUN, ...) { fun <- substitute(FUN) e <- new.env() pl <- .Call("xts_period_apply", x, INDEX, fun, e, PACKAGE = "xts") # need to copy other attributes to result? .xts(do.call(rbind, pl), .index(x)[INDEX]) } xts/R/startOfYear.R0000644000176200001440000000210213564762102013660 0ustar liggesusers# # 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) { .C('do_startofyear', from = as.integer(from), to = as.integer(to), fromto=as.integer(from:to), origin=as.integer(origin), PACKAGE='xts' )$fromto } xts/R/write.xts.R0000644000176200001440000000232013564762102013366 0ustar liggesusers# # 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 . `write.xts` <- function(x) { NC <- NCOL(x) NR <- NROW(x) DAT <- c(NC,NR) x <- c(.index(x), as.numeric(x)) offset <- 0 for(i in 1:(NC+1)) { end <- seq(i+offset*NR, length.out=NR)-offset DAT <- c(DAT, c(x[end[1]], diff(x[end]))) offset <- offset + 1 } DAT } `read.xts` <- function(x) { NC <- x[1] NR <- x[2] x <- x[-c(1:2)] .xts(apply(matrix(x[-(1:NR)], ncol=NC),2,cumsum), cumsum(x[1:NR])) } xts/R/zoo.R0000644000176200001440000000357613564762102012244 0ustar liggesusers# # 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 } `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, ...) } # # if(!is.null(attr(x,'names'))) { # dim(xx) <- c(NROW(xx),NCOL(xx)) # dn <- list(attr(x,'names'),colnames(x)) # dimnames(xx) <- dn # attr(xx,'.ROWNAMES') <- attr(x,'names') # } # xx } `as.zoo.xts` <- function(x,...) { cd <- coredata(x); if( length(cd)==0 ) cd <- NULL zoo(cd, order.by=index(x), ...) } xts/R/irts.R0000644000176200001440000000273613564762102012413 0ustar liggesusers# # 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") tclass(x) <- "POSIXct" xx <- coredata(x) # rownames(xx) <- attr(x,'irts.rownames') tseries::irts(index(x),xx) } `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/timeDate.R0000644000176200001440000000154313564762102013161 0ustar liggesusers# # 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.xts.timeDate <- function(x, ...) { xts(x=NULL, order.by=x) } xts/R/timeBasedSeq.R0000644000176200001440000000753613564762102014003 0ustar liggesusers# # 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 . `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/OHLC.R0000644000176200001440000000725013564762102012153 0ustar liggesusers# # 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/merge.R0000644000176200001440000001055413564762102012526 0ustar liggesusers# # 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 <- 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) } else { syms <- as.character(suffixes) sfx <- as.character(suffixes) } .times <- .External('number_of_cols', ..., PACKAGE="xts") symnames <- rep(syms, .times) # moved call to make.names inside of mergeXts/do_merge_xts 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 x # 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('mergeXts', all=all[1:2], fill=fill, setclass=setclass, symnames=symnames, suffixes=suffixes, retside=retside, env=new.env(), tzone=tzone, check.names=check.names, ..., PACKAGE="xts") 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) } xts/R/last.R0000644000176200001440000001043413564762102012367 0ustar liggesusers# # 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 . `last` <- function(x,...) { UseMethod("last") } `last.default` <- function(x,n=1,keep=FALSE,...) { 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 { 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 { 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 { 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 } } } `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) # requested periodicity$units rpu <- np[length(np)] rpf <- ifelse(length(np) > 1, as.numeric(np[1]), 1) if(rpu == sp$unit) { 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$unit]]) { # 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 { 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) } } } 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(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 } } xts/R/origin.fix.R0000644000176200001440000000446113564762102013503 0ustar liggesusers# # 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)) # z <- floor(unclass((x - unclass(as.POSIXct('1970-01-01'))))/86400) # attr(z, 'tzone') <- NULL # structure(z, class="Date") } as.POSIXlt.Date <- function(x, ...) { as.POSIXlt(as.POSIXct.Date(x)) } #as.POSIXct.yearmon <- function(x, ...) #{ # structure(as.POSIXct("1970-01-01") + unclass(as.Date(x))*86400, # class=c("POSIXct","POSIXt")) #} # #as.POSIXlt.yearmon <- function(x, ...) #{ # as.POSIXlt(xts:::as.POSIXct.yearmon(x)) #} # as.POSIXct.dates <- function(x, ...) { # need to implement our own method to correctly handle TZ #as.POSIXct(as.character(as.POSIXlt(x,tz="GMT"))) 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/MD50000644000176200001440000002431113611112162011373 0ustar liggesusersddf73c9103a2dbfca97af03b1578e49e *DESCRIPTION 518f63e0e0b5e2227a97e3bc2f558583 *NAMESPACE d6b24061fc81440422a17583c3f7c339 *NEWS a3f15cb729d860251bfbb8ddfc338b9e *R/Date.R 8f054b05f5ef9b9e5601d20f9d0b907d *R/Math.xts.R 383b8cc6bf360a22e8d80ed9abafc486 *R/OHLC.R e3cb68687658278892cab891ff63c785 *R/Ops.xts.R 560f0304d0194323afb04d2da3758618 *R/POSIX.R 415c8759b31782bce197387a89da94a3 *R/adj.time.R 573b0301e7d8ee3e0084c796492933d2 *R/align.time.R 136bd0e35a6f2ee066491df261c38fe4 *R/all.equal.R 3bdc88cb7dbeb631cce7f634f38c725a *R/as.environment.xts.R 0315be406636d3890f8c2291fa150044 *R/as.numeric.R ffcca9c07851f8d4420b7abe612c6ee1 *R/axTicksByTime.R 66e974e929d045cda74e1cc18b39f0ff *R/bind.R f4a0f67440a1f255bce14583dd2427fe *R/coredata.xts.R 44f55b7a492178ec120ead23ecc5190d *R/data.frame.R 661866dbc1a61fcbafaa73452335a164 *R/dimnames.R a6eefbf13641d2aa08989334efc85c55 *R/endpoints.R bc8dac1f89c727f9caf55aab54ae9d6e *R/fillIndex.R 9585c088d560cae68365bb13e0a9b293 *R/first.R 174d84b0e1380a711ff012e819a34d16 *R/fts.R e92e08c6bdb2942153611986fa5cf17d *R/index.R 2ed83cf34b949b430f603e3c006f94be *R/irts.R c3471e678b18a695ab366d4391a53082 *R/isOrdered.R ae36fdf55eb93dd0e6362b0b8d5d83a8 *R/lag.xts.R 37084ffa4be62acfa074467357ad160f *R/last.R d4a42c602d0250187df151fef6990872 *R/list.R b6388313b2e4b158b20c9f9ef99d7fbe *R/matrix.R 3ed0aac62551a2efb10a9896b3392f2e *R/merge.R fb8f9822aa4929b41f81bd3eea898750 *R/modify.args.R a9f1d1504d6870c4cf35178d040c436a *R/na.R e7af76f507e78b83488a2dd4849d9762 *R/nperiods.R f1e89591c22122cfc583897a85f67502 *R/origin.fix.R 421766bb6303fdd261de4fc43019940d *R/parse8601.R a4a6d1bc0d06a578dcb9889b21fd4140 *R/period.R 1cb2dfe09fcf7d7affc978211e815d3e *R/period.apply.R 7aebd9a6965ebf57e88e4341adc2e172 *R/periodicity.R 63a09fa8f22f0c275f89d1dd5fea5170 *R/plot.R 22e1ecef94ed3f6ffd9fa23e4ae580eb *R/print.R b7c5a1714ffb724cece1c055ae48f230 *R/rollapply.xts.R 114b6738367f91156a6deadafea9f8cf *R/sort.xts.R d5e4062a1f64a2ae0e9c7e4a4f7b2f5e *R/split.R f2fd7d16c11b50235732df58583f76c3 *R/start.R 7755f4d8138173926cb18940626a23b1 *R/startOfYear.R bb80b2d80b314be591e13b83a82e7fec *R/str.R a8fd02d7f9c6a8a979dd6dcb51e2b64f *R/tclass.R 7bebc76f7e5abc01cb524da718340a2a *R/tformat.R f19b50c1c39b018d306cb760cc886281 *R/timeBasedRange.R 3c2f282332883e62d19fa8eb27cda5df *R/timeBasedSeq.R d46b0e483e88a25285ed28100ec68a2c *R/timeDate.R 3cec5578127ff4b8e9e0de131fe86d01 *R/timeSeries.R 25b3ff04f5ddd4409f78849e7fcd3ec4 *R/tis.R fdc36303681ce33d6e7a7eed3b980421 *R/toperiod.R 3bce8788c82297cfe9e75aca9a78daa2 *R/ts.R 7e46776f72152403f857a3f71cdcb32f *R/tzone.R 47ab6d25a19cc4bd0699d58af2f8f633 *R/utils.R 06221b45c4ff5ec06ce13cb1fd408cf3 *R/write.xts.R b53a76e38db9b1b558604b5517f58e4c *R/xts.R e1a270f22d23d18ca9d27a57bd80a180 *R/xts.methods.R 48de6d6833bc5e608dcc972ca9b82441 *R/xtsible.R f74e70e98e7337aa15b3ff82e5e7327f *R/yearmon.R 3733678803c8e95cfa58463cf719cdd8 *R/zoo.R a45476f27a2d6ff242a4252389f50736 *R/zzz.R 961818b67271c20dd526691b019d07a4 *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 0d025af06492a5b276325bd3d0cfdc74 *inst/benchmarks/benchmark.binsearch.R d0289a465b825e78c5135b778c6474aa *inst/benchmarks/benchmark.eval.dots.R aaa8de0969962f40c9e2d069e115430c *inst/benchmarks/benchmark.subset.R adabd42da3589ec84451d78d16c185b1 *inst/doc/xts-faq.R 3cb66bcfb7b3c08ebba47201ba8b74f2 *inst/doc/xts-faq.Rnw 9bbd3ca5fb037825740433949492df3f *inst/doc/xts-faq.pdf 3d81a4a65b40e6b1cd3cec726449d49d *inst/doc/xts.R ff730516ee7c76aaabb6b97bbb326b53 *inst/doc/xts.Rnw c82ad00d817cf0d2c7b89157a8700329 *inst/doc/xts.pdf d7bacc956717a4e2b8d4b73ccadfbdda *inst/include/xts.h 345332af5901797d5fb9416f71e124aa *inst/include/xtsAPI.h fb8b821627015068f6c24f22e183728a *inst/include/xts_stubs.c 9875dd85dc2b34092f98e27aaeb91c32 *inst/unitTests/runit.Ops.R 1d6f935bac3d5cbaf7fb549a0bc9ea85 *inst/unitTests/runit.align.time.R f1e8e466d154a786d8acdb76266c53d7 *inst/unitTests/runit.all.equal.R 6decfffa6cb3bcfe83f0afe535a3544e *inst/unitTests/runit.binsearch.R 44c390133873d40c3a9de129f7acb75f *inst/unitTests/runit.coredata.R a09ffad34014e783386a20fc79d943dd *inst/unitTests/runit.data.frame.R d121e5ebb6a1827197e760abc4f3cd7d *inst/unitTests/runit.diff.R b25cd9bdaba12c610ff474a858ee0f1d *inst/unitTests/runit.endpoints.R 976b431dd0b8384eb1ac1f6d9ee0598f *inst/unitTests/runit.first-last.R 9c3d7505ad72b1c905bd5181f2d9eff5 *inst/unitTests/runit.fts.R e07439321b999f6d211c04ed00fb424b *inst/unitTests/runit.index.R d98e641ed60e472a61d0267fc4a5bff8 *inst/unitTests/runit.indexClass.R 9198aeae699ff64f4375e683e9c96240 *inst/unitTests/runit.irts.R 136ac49be32b58e5921a86f99441c596 *inst/unitTests/runit.isordered.R 36c7567c983499f42f0762d0425496ce *inst/unitTests/runit.lag.R 9976b1ce1a65a25fd51187f5db792589 *inst/unitTests/runit.matrix.R be2d0b0a712bf6c1e72e1f88fe9a52df *inst/unitTests/runit.merge.R 53fb156060c7b887260dde724b72795c *inst/unitTests/runit.na.locf.R 126d56bb85bcf47ebb32c1fcbbfe5747 *inst/unitTests/runit.na.omit.R bc1438886d7f05a0ed103128baaeafe4 *inst/unitTests/runit.parseISO8601.R f1b03ce18d94c05b58417449c07c2c1e *inst/unitTests/runit.period.apply.R 9fb247b3ed817538f0ccd609e772a306 *inst/unitTests/runit.periodicity.R 2650482d870601f7796965070cac4dfd *inst/unitTests/runit.plot.R b64b1fa493439f8ee9d2931fc9f820b4 *inst/unitTests/runit.split.R cdff9ee303a0e4a5d3a549a2457948da *inst/unitTests/runit.subset.R 4f33f14439369ab08dccd8c99d275439 *inst/unitTests/runit.tclass.R bef491bd0da8f0e3a545d766b317a81b *inst/unitTests/runit.tformat.R a90aff219d037a608281e3f2b3f06e13 *inst/unitTests/runit.timeBasedSeq.R 8616485a3662d85a8bea36c228dbc958 *inst/unitTests/runit.timeSeries.R 538d160f6e3ede96c8036d9104fa91c6 *inst/unitTests/runit.to.period.R 15c35a349bd4cec0b2d49ec57edfe101 *inst/unitTests/runit.ts.R 52ea74add7fb0e0f483210aca3e9e358 *inst/unitTests/runit.tzone.R c8d4b15ecfb07ba95168bdb8779e6d60 *inst/unitTests/runit.xts.R 8269d299f75ce65ed65255ea7ba0c10d *inst/unitTests/runit.xts.methods.R 2bbdcf002740a5cf4f0949416706be1b *inst/unitTests/runit.zoo.R d86dd454a3ace15cc54f55f57819eb60 *man/CLASS.Rd 35a76c566f8c17c131bf4a16608222e7 *man/addEventLines.Rd 1b77283dd30cdc4e9875ad083c5f3f77 *man/addLegend.Rd da3a9997aaa66e6d722e1caac36a47e3 *man/addPanel.Rd 857dabe09020d98f391c2857ad375f30 *man/addPolygon.Rd d998fe9a31d61533e32ab93fa3ca8c73 *man/addSeries.Rd a8e9819419a640e9ee0eeab0e9bb45bb *man/align.time.Rd c69dc0b6a6d39def9a4caad3e4e47989 *man/apply.monthly.Rd 4211d430658cd710c88057f6006f6cbe *man/as.environment.Rd 5845ade21632d95a7476ece32f704c77 *man/as.xts.Rd 8f3e892d0b4b4fa46599b9b5a2277105 *man/as.xts.methods.Rd c72f3424ed4715a2d6c3a581ec52bbf6 *man/axTicksByTime.Rd fb2126e68715f6f9f6127c39e93c3eb4 *man/coredata.xts.Rd d5e27a63ae664a5171ecfda3287a7ec1 *man/diff.Rd 313ebb0263535a867d6640705e708a14 *man/dimnames.xts.Rd a2ff5d5b3320b9d66d4c57f65a84e10f *man/endpoints.Rd 5183f5bec322d07d5f91c35f01c8927d *man/first.Rd fc0837c6af10e9de5c3502d5a5f869d3 *man/firstof.Rd 5a5700d85257411f02cf25a5e9686a2d *man/isOrdered.Rd ca3d5abe4db4fdb39f9ab697414a1b64 *man/make.index.unique.Rd a93d5d4043a51bfd337acf23fb1d3edd *man/merge.Rd 034983939ab5ba6f4671f85f76e675d7 *man/na.locf.xts.Rd 6b819569a0ce4d7ce155a124adfec848 *man/ndays.Rd 17df1c72965c703fa2cf2b8a5fc1bc12 *man/parseISO8601.Rd 4d2d02b90874edf4b5b3928fcad8977f *man/period.apply.Rd 4d3f6667999a07973792ed096d85db53 *man/period.max.Rd c66b44b141d576245ca2f2440de76e7a *man/period.min.Rd eced87d9eb44887bfea2ef54af6f799e *man/period.prod.Rd ac9d9c7f84b62737272e88376ecec110 *man/period.sum.Rd d96fffd493c13a0f22f647df78810ca3 *man/periodicity.Rd bc08fbdb9aff7ac32124d18ae840b812 *man/plot.xts.Rd 33ee7f0f4a540ffeee6f56e032f8e27b *man/rbind.xts.Rd 117e1cac129b3551c4a23f65b5c1db10 *man/sample.data.Rd ac032933c53a339d70b1015a4ad23b22 *man/split.Rd 9275b6cbbb3b2949015703aef74457a2 *man/subset.xts.Rd fc491d3ae5ac3cb0ab420c83dd7a96d0 *man/tclass.Rd 88564ff2e25cd7360901036944b4d9f0 *man/timeBased.Rd a18af035405efd81d4710aafd9bf3521 *man/timeBasedSeq.Rd 579450395ee8322544a06c4e4a0ae576 *man/to.period.Rd 821855d83d5444dfcfc1f7e687149956 *man/tzone.Rd 6b5de110a0751cb80e414525e427f534 *man/window.xts.Rd 5af65263a40d7d2b81818df0fdb3d269 *man/xts-internals.Rd ec3bc07ca065a0c35723d82652217b5c *man/xts-package.Rd 2615e6d3ca1a05c6bfa5c1c4cb477781 *man/xts.Rd 33d7d6de09ec6116204af9d128e6f9cb *man/xtsAPI.Rd a8587408f881a0c8b6f03f0145801b97 *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 2fb4ecc9527084cf84a30298a0740b46 *src/diff.c 1b3a1142f5567b8127c5181475d5d357 *src/dimnames.c 4d148e934a4f7b8c13d06f356f79e246 *src/endpoints.c 8976d5497755417b9b6eddf00b5d4349 *src/extract_col.c ffa4b90307274a1eaaa9119a3949f2d4 *src/init.c 5a1131c5c4cda826587411b399762e94 *src/isOrdered.c fe6ed8db5aa6d0f945acb756d2583caa *src/isXts.c da84dfe355af4a2e229237d0a8ce9a5b *src/merge.c 446c85faf6eff092e25416c12bf123d1 *src/na.c 01224b29afcb315e3b2b022f89cff4f1 *src/period_apply.c 98c3542c73b9d2e3bcb0874c93c199c8 *src/period_arithmetic.c 9d155812d858824aed442e88555e4e27 *src/period_quantile.c c65411fef0c7755a5de720fcffdea5a9 *src/rbind.c 7a60c01780f630c072175e7134ef08d9 *src/rollfun.c b6339594a3cf5d8dde13a6f9f771187c *src/runSum.c b2e02621de1b5994da644a0accb3ff2f *src/startofyear.c 8b82aa3c1336652137236dfbdce1123c *src/subset.c 215a490e1edcdbf627eea9fe03f5359b *src/subset.old.c 0139eb8441e8dffcfc001dc33b1986e4 *src/toperiod.c f871d8c4ab2f7a1b5cd53c2cb3b99079 *src/totalcols.c 88328494cd56efaa612aaa1d0dbf3c03 *src/tryXts.c ddcf2148cb8071a63182c5721e80b404 *src/unique.time.c 194e486d051eac51647e84ccef3bcf57 *tests/doRUnit.R 3cb66bcfb7b3c08ebba47201ba8b74f2 *vignettes/xts-faq.Rnw ff730516ee7c76aaabb6b97bbb326b53 *vignettes/xts.Rnw xts/inst/0000755000176200001440000000000013607332267012056 5ustar liggesusersxts/inst/benchmarks/0000755000176200001440000000000013564762102014170 5ustar liggesusersxts/inst/benchmarks/benchmark.subset.R0000644000176200001440000000256713564762102017563 0ustar liggesusersstopifnot(require("xts")) stopifnot(require("microbenchmark")) # Benchmark [.xts using ISO8601 range on large objects N <- 2e7 s <- 86400*365.25 x <- .xts(1:N, 1.0*seq(s*20, s*40, length.out = N), tzone = "UTC") # warmup, in case there's any JIT for (i in 1:2) { x["1999/2001",] } profile <- FALSE if (profile) { # Use loop if profiling, so microbenchmark calls aren't included Rprof(line.profiling = TRUE) for(i in 1:10) { x[rng,] } Rprof(NULL) print(srp <- summaryRprof()) } else { cat("Subset using ISO-8601 range\n") microbenchmark(x["1990",], x["1990/",], x["/2009",], x["1990/1994",], x["1990/1999",], x["1990/2009",], times = 5) } cat("Subset using integer vector\n") i001 <- seq(1, N, 1) i005 <- seq(1, N, 5) i010 <- seq(1, N, 10) i050 <- seq(1, N, 50) i100 <- seq(1, N, 100) microbenchmark(x[i001,], x[i005,], x[i010,], x[i050,], x[i100,], times = 5) cat("Subset using logical vector\n") l001 <- l005 <- l010 <- l050 <- l100 <- logical(N) l001[i001] <- TRUE l005[i005] <- TRUE l010[i010] <- TRUE l050[i050] <- TRUE l100[i100] <- TRUE microbenchmark(x[l001,], x[l005,], x[l010,], x[l050,], x[l100,], times = 5) cat("Subset using date-time vector\n") t001 <- index(x)[i001] t005 <- index(x)[i005] t010 <- index(x)[i010] t050 <- index(x)[i050] t100 <- index(x)[i100] microbenchmark(x[t001,], x[t005,], x[t010,], x[t050,], x[t100,], times = 5) xts/inst/benchmarks/benchmark.eval.dots.R0000644000176200001440000000051613363341256020145 0ustar liggesusersmatch_call <- compiler::cmpfun(function(...) { callexp <- match.call(expand.dots = TRUE) eval.parent(callexp$foo) }) subst_alist <- compiler::cmpfun(function(...) { callexp <- eval(substitute(alist(...))) eval.parent(callexp$foo) }) library(microbenchmark) microbenchmark(match_call(foo = "bar"), subst_alist(foo = "bar")) xts/inst/benchmarks/benchmark.binsearch.R0000644000176200001440000000203313271351734020200 0ustar liggesusersstopifnot(require("microbenchmark")) # Benchmark binary search N <- 2e7L n <- 100 set.seed(21) ivec <- sample(N*5L, N) ikeys <- sample(N, n) dvec <- ivec * 1.0 dkeys <- ikeys * 1.0 binsearch <- xts:::binsearch # warmup, in case there's any JIT for (i in 1:2) { binsearch(ikeys[i], ivec, TRUE) binsearch(ikeys[i], ivec, FALSE) binsearch(dkeys[i], dvec, TRUE) binsearch(dkeys[i], dvec, FALSE) } profile <- FALSE if (profile) { # Use loop if profiling, so microbenchmark calls aren't included Rprof(line.profiling = TRUE) for(i in seq_len(n)) { binsearch(ikeys[i], ivec, TRUE) binsearch(ikeys[i], ivec, FALSE) binsearch(dkeys[i], dvec, TRUE) binsearch(dkeys[i], dvec, FALSE) } Rprof(NULL) print(srp <- summaryRprof()) } else { mb <- vector("list", n) for(i in seq_along(mb)) { mb[[i]] <- microbenchmark(times = 10, binsearch(ikeys[i], ivec, TRUE), binsearch(ikeys[i], ivec, FALSE), binsearch(dkeys[i], dvec, TRUE), binsearch(dkeys[i], dvec, FALSE)) } print(do.call(rbind, mb)) } xts/inst/doc/0000755000176200001440000000000013607332267012623 5ustar liggesusersxts/inst/doc/xts.R0000644000176200001440000001251213607332267013565 0ustar liggesusers### R code from vignette source 'xts.Rnw' ################################################### ### code chunk number 1: a ################################################### 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) ################################################### ### code chunk number 2: xtsconstructor ################################################### xts(1:10, Sys.Date()+1:10) ################################################### ### code chunk number 3: xtsmethods (eval = FALSE) ################################################### ## matrix_xts['2007-03'] ################################################### ### code chunk number 4: xtsmethods-hidden ################################################### head(matrix_xts['2007-03'],5) cat('...\n') ################################################### ### code chunk number 5: xtsmethods2 (eval = FALSE) ################################################### ## matrix_xts['/2007-01-07'] ################################################### ### code chunk number 6: xtsmethods2-hidden ################################################### matrix_xts['/2007-01-07'] ################################################### ### code chunk number 7: xtsfirstandlast (eval = FALSE) ################################################### ## first(matrix_xts,'1 week') ################################################### ### code chunk number 8: xtsfirstandlast-hidden ################################################### head(first(matrix_xts,'1 week')) ################################################### ### code chunk number 9: xtsfirstandlast2 ################################################### first(last(matrix_xts,'1 week'),'3 days') ################################################### ### code chunk number 10: tclass ################################################### tclass(matrix_xts) tclass(convertIndex(matrix_xts,'POSIXct')) ################################################### ### code chunk number 11: xtsaxTicksByTime ################################################### axTicksByTime(matrix_xts, ticks.on='months') ################################################### ### code chunk number 12: xtsplot ################################################### plot(matrix_xts[,1],major.ticks='months',minor.ticks=FALSE,main=NULL,col=3) ################################################### ### code chunk number 13: asxtsreclass ################################################### # 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'])) ################################################### ### code chunk number 14: usereclass ################################################### 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) ################################################### ### code chunk number 15: periodicity ################################################### periodicity(matrix_xts) ################################################### ### code chunk number 16: endpoints ################################################### endpoints(matrix_xts,on='months') endpoints(matrix_xts,on='weeks') ################################################### ### code chunk number 17: toperiod ################################################### to.period(matrix_xts,'months') periodicity(to.period(matrix_xts,'months')) # changing the index to something more appropriate to.monthly(matrix_xts) ################################################### ### code chunk number 18: periodapply ################################################### # the general function, internally calls sapply period.apply(matrix_xts[,4],INDEX=endpoints(matrix_xts),FUN=max) ################################################### ### code chunk number 19: applymonthly ################################################### # same result as above, just a monthly interface apply.monthly(matrix_xts[,4],FUN=max) ################################################### ### code chunk number 20: periodsum ################################################### # using one of the optimized functions - about 4x faster period.max(matrix_xts[,4], endpoints(matrix_xts)) ################################################### ### code chunk number 21: devtryxts ################################################### period.apply ################################################### ### code chunk number 22: 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)) ################################################### ### code chunk number 23: subclass ################################################### xtssubclass <- structure(matrix_xts, class=c('xts2','xts','zoo')) class(xtssubclass) xts/inst/doc/xts.Rnw0000644000176200001440000010065413564762102014134 0ustar liggesusers%\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/inst/doc/xts-faq.Rnw0000644000176200001440000003003413564762102014673 0ustar liggesusers%\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, mean) period.apply(sample.xts, endpoints(sample.xts, "days"), mean) period.apply(sample.xts, endpoints(sample.xts, "hours", 6), mean) @ \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',], mean) @ \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/inst/doc/xts-faq.pdf0000644000176200001440000044606113607332266014713 0ustar liggesusers%PDF-1.5 % 84 0 obj << /Length 549 >> stream concordance:xts-faq.tex:xts-faq.Rnw:1 47 1 1 5 34 1 1 2 1 0 1 1 3 0 1 2 13 1 1 2 4 0 2 2 4 0 1 2 4 1 1 2 1 0 2 1 12 0 1 2 4 1 1 2 1 0 1 1 3 0 1 2 5 1 1 2 1 0 1 1 12 0 1 2 8 1 1 2 1 0 1 1 5 0 1 1 6 0 1 2 6 1 1 2 4 0 1 2 5 1 1 3 2 0 1 1 7 0 1 1 7 0 1 1 14 0 1 2 5 1 1 2 4 0 1 2 7 1 1 4 3 0 1 2 1 0 1 2 1 0 1 2 1 0 1 2 12 0 1 2 13 0 1 2 7 1 1 2 4 0 1 2 1 1 1 2 4 0 1 2 9 1 1 2 4 0 2 2 4 0 1 2 4 1 1 2 1 0 3 1 12 0 1 2 10 1 1 2 1 0 1 1 3 0 1 2 1 1 1 2 1 0 1 2 4 0 1 2 10 1 1 2 1 0 2 1 3 0 1 2 1 1 1 2 1 0 2 1 6 0 1 5 10 1 1 2 4 0 1 2 5 1 1 2 4 0 1 2 3 1 endstream endobj 106 0 obj << /Length 3023 /Filter /FlateDecode >> stream xZ[w۸~ϯSꉱ{zv7irN6<$@K$zE9;Er줛m$ oDN?8}4\hDRE:,\%'oJv6y6U:M8ϴ(%4BNBG Y=V%U} k|v\ttRk\T؅RVY6@9uǩ;- ' `Hȕ/^+)w=p5JQXЭ͸aish9ͅ3Բ)W]߃a`-Jo^=I!Lg43+ kaJ8鸹7ER/I4\Ef({j捐Y7?"6ۓDLOlQh}5',eS  vȁ}5F tsV M/XT# ۣ΄ɋP MUxf_lF:I?XOa%H74uWoyZWт k럫_3\ij`iPeZUw" pNc^Zx[,>LFQs2㥀eąk+OT<Ma*5p|ҰGFUIeWswG*ռSs9~Z oK~pJ<ġi i{`m `_9f8Ts򣡖Kqmx衕yyC"f(&O%_XiZAELr^"Qeu.Y֢PnWs>gIK2kUyGVzl/qMhcn)zN9V/i tz<;|ȬkDf6(sQ#T]X5UBܢY^ 4C |V4Ϭp6fHD u?==tBӴ.=G+gl>MD0[| ?,hnj`I?LSA=`,{mT{Ȳ܃]"ՌtQXH|Zi챺zM`P 5g$Թg49z30pS߀{hH_̀-Y0[/.I m FyE~qLrƕ`΂I5:%曮yܮkvG $Ħd=˖:P?oa&9tӬH&bpJ/uMTSE_giZƽm8P+j!I:6ՠ|wsA:pEͫ(1n!i"@Q>οՍi a~=r2CՃ%?@im%Ն{.tF#j~HHԮ6!T ouH3 p>|Kwm4:2ys|]v%1v~a}Mx2x69 Mbx9ltga R.hM3K5Cb()2ɺm33ĭ2h- X=ޜQ8N nx9׃^BƏ[ ׸d !LJw2oD`F]F2\8}C`q dt/󃬄jǁ*(W?pJAVTe^dToFa 6ZrQ!EY.4'.e.o{QG>|/%-^g1+kp)ދ0X~vceAUM$2&{96'h-{( Zލ)+|zĹش2{y\y4Xq:,JGmZP.r]PW,>`+r>?8ֹO$VSiݞO<*cjޡn:C.|Bhr$kPo9O=*:8Ya-qQ#ͬ|=df,.ҡ u.3'B;%t\顿ڗJ0RdF G%ǒ fm!˄S[ZKJy XBpaFf Fpz1jV`hUW  沒F;FwOܡWPAbbUbel, m'?>x  ,6af|5XmY~'ʭ"/aԄxD\]/hńqMEeJ͟96]5qxDaw']І'G J1|SQ!CN k^TwGzn9 `U%|w @xuq|O~}x{ژlr2@)䚪=h f5yG>Kd{3pITdF|@]E٭P)h]8?Aa)!ǝuz'&/ֻ*ʿ%O`DgX{,>H m `Akd9W+.fƱ,WtޱFWn7e擉xӛ)DfC#OM n?_RƂn '2Djů:A:hrdwhKVYOkcA> stream xڭYKPb 0IeRMGgTjFڕHY/h]>H"A[a&߿޽}^tlVjg3r1Ϻ4_2O6pytwK=~ZK< 2b\ZyJU)p¥Jr0kn4Y*˂8"Ҥ&D.Ä8*8L؃2<ϋ~hYvcm `Ypĸ^ ~mjCմ񾫷rICp`X _]]-Q~-yj5YeXG [92[gOVdDL~I;2Ud\0i qA@{T&*q;i9E]o~-23>d҉EJW3¦]ɓ3>ibIz=U:b5i8QvS+LeMb\eU0E/Ip?Z`DA,s۔FB 5‚wppGN|txSR-Di&O JU^y.^ KX=Ƕމ#Gkzwsg腭Yv0ڧew_]S-)lJWZZPN4iǣ1 F&),AҳI5@߂#&K`F. ?t|z)vPV*/Ǹ+[t(#ɞ2 !ĘId'N?fSl7ñ`םwG@")ϒO(9y-Y6G!(fVuyl@hkdKQ" Zig<|ې馁[#@6Fn?HGGHwd3t@R;v; ޺R~*S7rpUΡ3_/[Hxr*TObI9#le]qqvk#J;w}g֟:|SopU'@l) 6:57xHrf"[ANEr,& αA:>?H|_?f|`St̬g#օ ( t͊Qɟگ 9!VU u(Cu c%ݭDyp$BVdw]17NP*wO#{*^9A=2g,R6N/i5(!E&mj9Gi6G)ɬ JCQK8y`9 2"G٦茀___' L]6>/ o$^Ҽ0[( GӮN_cDti ^{x z CPj5cԶa6a>bP_>RG(X-(w%jf tN8w# *қ+"[A'Dߊx$V#FPb黨Z6Z*rDnQp;D֣*sY?C3HYq/g]huWh[8ԧoTTC-kaoU0#{8z3~v9disl'|Ko-5?gnouE>mzw;评6S6jK:#PqK;j9$Lks?CYqsg O##|05uz6VMl8XJ~|NĘxNN]IAz7AO. qm2-B,AO_RFk&Rvtyq=$4(r0*K`j.(v;RqGθmktӰ845'2y&A@Ҿ>m%HVc~~%}kHΕл^"/eg"#WS˰h@NkvZ endstream endobj 141 0 obj << /Length 1395 /Filter /FlateDecode >> stream xڽXn6}߯2vŊDIn%zAkҠP$%vaK^euH@3C ^joS/Qƛ_x2 gR%(wy= V,PƯEEST_OI*$PC/bY+_5,!㬊3}Ba$O3`/jIn0bǥG.-PFY؝Glt =ؐq"9^A{Q{+lwb_ D><ꨣ^iˊjw'q(>5$[ޑ*IIu|RrJ=\MAPA^XH$icr@얃.6xhJvs'Pج1U l,iJipŪ@+c CT}Iuvt$3›B`f%8ZƵ%DB[w-OR˯ 8= h&oU=tc b S*T gѝܓptn )nĖzl@ "?m9JjSEr.фo/~QE endstream endobj 145 0 obj << /Length 2000 /Filter /FlateDecode >> stream xYݏD_jֻϊDं>/9zCpw=:qJ8@xe;;3;;_<[ٷObɳi>ӉIffW38eQyϮ70Fm ]}elD%Bޤh2ܢPI; К^z$Pq֋iNU^AjlviVMhupƱ 3T0qD1ovÙyw J,2+U G:ϕ#UϰcD-h6wYP!^`ʫE݄8W-jɃ{\^Wlbp+s"TRn%m=oJXs} t8~\CZ]3n:Σ.PKƖy01VYRJO(˸s0VءnXY@Tb )#Pv=Z ;3J_d\,h}, j7K:c2NbCbZ*: Os}@&ցHV趞Bsa9pP 'LjT[^zӖVP.#L_'R|Gh uPK)IhKmBDRʫ% aHU0+*Z-{lwV__bN5@v:MUiN(Ѕӹ+Ub҃sӭWLү&츇Oq蘭}P_.7$+&ZJg>.MK*kv O\NL;V!e13F1_xV;'Z] u4ʔ e$;2(])){㬯%J䆵~hsccH_|Gˬe+R}4 drz3OۙO™ΙVq/hǟj}7A[[_S* *цo X endstream endobj 2 0 obj << /Type /ObjStm /N 100 /First 800 /Length 2636 /Filter /FlateDecode >> stream xڽZkoSZ n @2 jXsIZR~}r_RI%fIޙ{̹ΐ$Ȓ8=IAIJORڐ $%5Q ,)K&:R,?"-EMZW\y E1Ƣu Tg\axx@ae$ 8#wdq0^UFJh Ǡ^ tƹwU,00,-ow(i9]b/y~C b>Kົo檨-.lyҬj8;pS[\WH~)ڦKcߔUz^報n/ِ>ղ`1->@fmUYϋӢݚzNm1+;7;"ʷG-:PÆWt| =tQ?7I.mS_ WS$듳?'gNNԼ,.C=dFl$\+b}uVu}~}]%Kl͂.uoqw/-e[Cd֚] CտԻ+P~gW/Egx }!7GX(;L׋"nzBSwM;ӗmf`2pR9`@6-w~P^ͬ:t,f!F< HCCX_ ^\Vy;x(9 U3zIYSy1p>-+-uч ~+馔qʇ:5JS"R SG}p/H|{qǺ3T7cރr[e1ϙ2KÊ hUyU|:[ž^xnY˽*(We9XTX޲Tކڼ&iX>_\@Zu`2wptrA2شCL&jΗ%6G-MΔt6-j.NϚyY#Ȧ氋TlPF9HrNe5g3vŌF(emeDfjSS~*aN1}z3Jj(mlؚ,yﱓ(|7eG}z2dN@zG2LD_Hiwn-xՇ H &쾩tG^?4!5|lJ15Q 54z4y)5v; x9 Gt{Gojx4blXcFblѷO+돓M;/ĝ0~v2]0H*4,|Y9JEa 8<* 6Z8* ɸLڏC?`2i(3bb2+=I2ruc͇G }@#̈C|' T =k ƊY D-xqq|(tk5&@ӡ°x~j TQ6s>']-@OPUY@EKsȣ|C4P!"fXuH#kzyyyŖ8dfgp0{at Z6lH셤{~6,-\la<psGCl'zxƑ|w1B$[4*1Sص}}B?ы8iRi\:BAꂿIDUaec`pf474￑KoMo6DGc߱]ѺpaWHyՐkYKY{$f~< .k,8pQzQڎU?#ؕ ȇBWhF/m۵xn yX5?tooVwsopoAkgq|~31RMqt  endstream endobj 150 0 obj << /Length 1881 /Filter /FlateDecode >> stream xڽYYoF~ϯ܇P+hR@Ӧm@$D+jdѥ8ʯαP-nh.gofvi1YL'xU'y'*\\MD'$SQj|&x3}}M]2 SQs Wv0V>W1YD -¤iqoݒA쀹uHIKA}깛zaH=o$ꓓ+V v:GƴKCWÍM<yf%{/{4z n傯Yd<pc^.iԧ~={i"mZmH Y嫦ZP&k 5ojdfz=/,jO8-hpdP3KʠҷBqla|]2X˭y%zd PMY92w=pGbZir ;-&1ckz7+Va-]I geHW('))\"ny/:Džv҅$_ACXi(2FlPA$# Иx Zmi$QpB[^`Ml_[ʢ86Ŭ7 cV5;Z,9Snn5ͺsi4NJ;%EB,Nm5*d¸kNҶ9@>}GRX¬%RZY].Իb/gZm76qzX\r}FC{HF>G{޵A1 c'$jՋי;tFcp|µmpIJΌOi.~0U3ǂkAC./q*ΓZ#/x~gjsO>V\%`=ZV|h] ^q=lc,쒝~oԇwRſRqno)݄n8ཇz/άm=$ ݓ~oX50~/ʽ{&2pB<[P cNx{UboL!cLWKz$ғ}wP_X=Kn}ou0?{WqD;"L1?a7~PBG:6ye',ɿXw endstream endobj 156 0 obj << /Length 1869 /Filter /FlateDecode >> stream xڽYF_D̾lQ)U}SMbQ̎es~׼3H~#Σqttn$VřFm4˨VC[M$5"簆*rh $Q~-'*y$b?/!Z4/aoY|EC6x"Fڤ HjUbex$*|с5u{eKJ+ÞgX2Y&f6I?Ҙ1EI3F)t-Ѷ 8Ykw p;G[ٴ3h$ c %P;u w%`dluK8E(j<1W&$X } ,\g9>% *ڔѬS9l7iyRѺ)g2 e値U* zRf  ap)lگeB BPaxchv4]N.ms =,yu{nDK?n%RF"YSP% nIՅ*.)xK WD8uu@Re 0dve`gl>39k퉷:H B'!fS@WK*)Ӊ}b' (BK='a'ưo1NzVg$e8>-Вj7fCI-Z,g8?^#|M-'.u-'u闆Gi`Zn<~9_3~gx[?vChG#o B d(&Rt2$>~*=|m7iy0{9 ^ (//IPF|##mW|Sq9X pdx rS/JF] 88|XySU6E+ͩ@'lj P~]4u {Jλ}$K481R!Ntu2f pdblMtZE{B 9Aِv+ozmnϡ : 믯5%R/K!y\~1=2\r\f1C^8dTk@y%+{8%NK[%Lbux桵|gO͠u֔ëb~K Mc+%[ccks]|M!?.W\)LB>?8HZ endstream endobj 160 0 obj << /Length 2260 /Filter /FlateDecode >> stream xYm~=UR$h{M{-ֲ֮ow}ekQc>"pfpl7or(k[,K _4f.Kd𬤭]6nJCjZ_EiIBF-o[PpTZ:wnw.oKאhy$J3DEd~Ƥ;)$<,WI[}I_hY/J3Xw-}\?xůMCHv)(4M tyZRv:{x`6-6(P; ne`_w'$ I=r6,llCMH\G52eQ XVax:X+[bbӁCw`y]% >2~ݞܸ O#3 XmuzB!9MUv:H9~-6JEZ( Y3o4Efb_A E5KUrmIFYL*ԟ~zAb^J͞$2OLی,ּ N^Hj;KU*$VߺuZl;;l#o98.D$0E{dT]Ï8= Bw&pb7F5Јd^W= z:t$S$|ESszKNvTPBȐ5=0㉠[A}2mK^XT}:jEfwů=АӬV(YdFfUԯZn`֌k@}0ʤ.qۊi( ?2Ġwx>/~&<\y- SMe],oxx7yyĒA8Є|N7ec ~&J pe,pLdGOEp \fX6.|)*xJ߫C #cP/8A6g~\n'ηo1cG /dtCzZ~ŹS ~K57Hg}8*&zJ <_J?fSX<. ZJ.6(7V2JC rna1F&NdF ҿ?w$Kr0+T_bXU1wvccX;7Gpn:pC_%"5ky :h! k8᳕ê>&|*ܭ(`V@h|"7z Oeڍ~E"V魰[w9.=cszJM^*f ]HT#@;j81I\\!{ȟ(W r9=TrHQ3(nM\xhd\Cw-4/fF 5Q#4^:u$A`{)oۅ\s83,UKAyhuƝ5=` (쨻꣰T6\1YQي`^h={V sy怗'Җ÷qj;+]A3ܡˌ; TXJC1q: ,U&iPڑUu(4;mcNżCX;Ni-9Rﻇb[ QImIJ [Iox?ce-#`zIHpF3h4DeP3}K_:EWx&$MeDv<嬼ʶ!l%$ ֪fO ɉ)Ļ:kEpͪvG8 0x{!v;]0L`Zd`{@4tצy)4ԒA2j̀z? /@d3I,u?>DuhȕH7qn.INN$V>"{_@}qwUID_٧[u]᚟> stream xX[F~?՘BUUj&J䥖D*%v۾D}囋Ol8x/sQ,XlǑI ud,<&f?JP YZJfõs"MG_(|+G@ow@ }^ K-ϓ(b6łYKЖF,x_N%g^nI;z=#A|5/@bR˟e'9ۊ5NV5mG8޳C) R9{j=@q]tXmpņ+ңl=KȻ)k4^CJe3 uE64k(6Ǡ7$5^)WJ 6סGw{&9 ;@| ]&q|uiب>vw$eM9~" }A$#cWkQs(aI~F,0ydW`)60mt9T*1%aK}R!h0aK7vmQԙiXJw%/>=uW_nj\#gCx|vȯo-.ڃB8chtL5-/ ˡr Sۑf+sR= YXVA7\zH\"9L[ݰ:p1YejU_gW񞘑KJXlDʱ~=ly͈l2pF$qN_<09r ?>@5OW* imhj]C;VpU7Mu+vn%NC;hAy&S5b…)^Td䪮f<(N|t9۾jO4PeFCC)e+7sșN*/w~5W^2{mR,Ҕ endstream endobj 169 0 obj << /Length 119 /Filter /FlateDecode >> stream x313T0P02Q02W06U05RH1*24PA#STr.'~PKW4K)YKE!P EoB@ a'W $o&| endstream endobj 175 0 obj << /Length 104 /Filter /FlateDecode >> stream x313T0P04W0#S#CB.)T&9ɓK?\K(̥PRTʥ`ȥm``P73`v(PՓ+ L5* endstream endobj 176 0 obj << /Length 122 /Filter /FlateDecode >> stream x-ɱA($ \vTSHB $:@\#Q_TQUE&MG-nu8M [Yð,ΐV]'v=WN;S3uz3x:cE_ endstream endobj 182 0 obj << /Length 135 /Filter /FlateDecode >> stream x3631Q0P0U0R02S02VH1*22PA#CDr.'~PKW4K)YwQ6T0tQ`H``(`   ~$~K  dE@Yb..WO@.gC' endstream endobj 183 0 obj << /Length 118 /Filter /FlateDecode >> stream x3232T0P0Q54T02U06SH1*22PAsTr.'~PKW4K)YKE!hT,C(j  P); endstream endobj 190 0 obj << /Length 150 /Filter /FlateDecode >> stream x3632W0P0Q0R06CB.#3%X"9ɓK?\ȌK(ʥPRTʥ`ȥm` *og`?: A u } )v endstream endobj 191 0 obj << /Length 119 /Filter /FlateDecode >> stream x3636U0P0Q54Q0P01WH1*22(Bs<=\ %E\N @BA,C dXlt5# 'W v)1 endstream endobj 197 0 obj << /Length1 1510 /Length2 7915 /Length3 0 /Length 8917 /Filter /FlateDecode >> stream xڍT6 ҍ=t H7t  1tw"! )")){ϽYk}v>]άϯ` (~PHS@>; -g7ÐB:;C(w)ܠuNo`CnEs)mr'@1Q zC7qQut5A~}PO#|` 6P{?P;ߟ,eD}c~45x:EE7_T/$wF !ӿ*\/7ci!X p@ L?. F-H0w@-&n kj kipթwk{0w7V8ŕ䆿w C@uߏ n Nw!w{)>wW|DMz0@PDݹ!ߧ@P/$|ǡ;"A?@?TA;_@Q ?P+_B</eBI$D*ı6F΋8q:7[%1N Kn )]+\'L78t[&荮OP o+}b7_q3 rhFoWgw')$;]`'ׯc -& lrR`py&897|ˤ#\kM(볅B4l4f 'G9|7Sթ|Kdr"fC>&~}bD\-_&+P# 7 k88p}CU풪Y˟.nXMmy:;v yI.TFqLv*K].^̠sJ b$ȴzpU6[KxNs&}-M~o,ɀjMյ|("łUQ^*HԠ&F컳a_&O`cpS3ŀRC"h1Hυ%QxzѼ޹ĊAԱ_C]R2"qVvŅpԻoi,Nht|[ClnMY+])H8Ǡ=|zUWkf|oLt&E/VhL#d7^ 4)ddA߱MJwnPkpPF]4YfєЫ|jv|%u6X 4D;Ί8Up܈\X?Aj$qn"@./{Y  uX UD^p~k_`Zn޳l TWdۊ{݊-ΦF=ݙ6URƤsG)  xٙEOFHj"Y/'c٥_uH/v:*uo³9X!>TH#*XLHbh>uۏ=TOOY2~㻯D5fcwb$Bl ȯчcSN%}As뎭%W ܾ?]sHTŃ7𼫫^j/&̂4u3HE|TV7k/_B졯̱hjo]KhJ" 0D;}8&Chweұ|Atuɹo~N"Dwcx^Q';>|a~D8mÚMoK\Co@j}=t|['^MiXSsg\  NXoWSo]ZNJ a >Lz#GRb7|9?d9wpEa3/x/_=,*)cv>>.Z›!-#~(zf ut#3OfJs5KYYcE %OEa U ֢{zsqf|P-I Q壾 7b2 o*-3@/rUK]x` T-/$DfgҴee:"[<񞀋?%_[#!r?ZMj\E< ]4k$@<W%aP㎈_̗^֚g).$fGp-^TD>%Žl S2#%D?wg繷M7BI2gKy  x퓍 2}J}`DÊPs"ڀƵ0pirSк%B6 ,}ۜ[>9V Ee2Ǿ?~lT~a{g)$9Bm!⪸ihC'v8ZrJ5*f,N$t:Fsrm~v st"P=+f~V"jGF~5rWJCWf nYVPV1ހg% ]ˤ5Sc^ULDE~϶/ºaXG 2&]}%Æ32}ZNd#YM1m$PY$%}<SO6=3b 8N?_>V6}q\^rZYԒ~$[}pv*tr.3/%2-0096 v =woYӹLego9CЅR fZ/Bĥze 0z1krKj#X;;BC+j䘖فFB阻T}0՞,^6&MU*!P䅟"M.l\s`y+$\ VO/#W~ _9t!'2V-F 1 >.( _y!(1c%/қK~FX=f`)$Li+iģ~tnsѣk#s'lROYO^ޠQ~x=ΘC,안?=їDޚT C6(vv)4R"+7 ~b>pґ#Au(LRBP/R/};tK /O vBU\5dEha PeBb\hͦ7N˵}K}@ە:nr8 S4wBPѥ|^߯.͚!H~O%)PU+2xX^5 a^$~ɮ+JnŔ^i_jz~a|aۉK:[տ6Pe?Mo̵ѕLj6JA\Yf6!RR3oQtwJhnOEՋP}^f 5Vk%nm\0 :>["cْ}i;XzzLt:ȋB9h&1 %A~HpsDyȋ¨+_XH8DK K,Cz[6c<,(~fӀj?Mn7f/1P74 v 6wI\xYY9>Ie{vW3n4˄>xJӝU$}%׫ҏQZEAOɛE'y4 !.z66Տ٣/>X9WSm]=vScn02'NsnT!vBl`>qeAcWX?JR靸/q knVs;;,&lQiicBE@ P#l~W&=+U92#"uI'4Y`4)Ӑ\R.) 6̆2e_-P]X0Y7PBGD*bz^Jt]6vo b:Ǝ>'!Lלe@l(PA;kSO umɇC\hIR(U7_|. "?:&k>)*I߈ +!ڏ֜طDF |ҕ-imPL*aߍtV[h|H+)jL /}[N4YW%-"+dtܙLzv b;r8Q>ߚeCYq %.}LE6{dn7-fV EW+/׻ϛǫnJRj5S@$`_?`v#L߀FwmdX7S٩?%D{?U5G*- ݺV0 q$I#F?sUƐqrkzۤL +FI#汾1/}riYz$gc y?c*~xQW4soXǢuDŽ&95Kgp>ń9H<J  b.Q&?7 HL"]#&ZK5HCnN}6RJ936&:?K9Nh0kꛦ.ƅl:*=%buY9Ru }]C\=`<*|nsiRxʱ|G"[[ahiC@\TTڗ)(PC,sZDt[˓0Q?Bii)A8Š(RP/ΑY7o0ݾVM]/Hg \Ͷ',[c2_KXtF.B\Ub!S(V74iqjpg 6pb^* aa 's4PYM?9waX(Տ*rlE%bXO]啬^fo ǾY}՚eܼf>i2ZJnd]< WjZvM%S LHPo;Of.tu]iMh_='A ՂIklqTgsC579DZF/ih91цJǕuJyk5-+)K<ˊP,Tإ`S#:-N,K XL"4iiKT:OrIM W[mt?w42AJdX 1IB$Ȱui&tX /яΤ6f!2ѽN\5g{=FB,/-uUq+>wBΰD+qxzPPȓKྒkRK+- q:֞ܕInW5e3[އʇ>oD7 Uf19ur?oB?\=HPd؍l$eҌ2{t=^cE)i5Vl,մ'ƒ N.peFgМFt7n:XT*U' ,Mv =+ɥQ &1y%k0@oB endstream endobj 199 0 obj << /Length1 2108 /Length2 14592 /Length3 0 /Length 15854 /Filter /FlateDecode >> stream xڍt] IlvlsǶm۶6v8mƶs1{33.RBy%Zc;CQ;[gZF:N:# T?rXRUG' ;[?B&2aw-@ `dddd`010CsZdv&NBvfq 004lL- l2&6 JvF&も͍ٞƉьflP4q2qt51U2@`IN(L Mk #[w[cG{t4@?01ݿ9 `jamsvwE4v{7p560|'@T@`^99Z;;9YXU#_n,bk,dgccbW~&F}pllL-lM*Ş^DB_λ8L܍ ao/{ >^v2L|,LM` \MΎ.&>^*22-&fMLhbx?F_OoGL)&)BoU ڹhYLFFf ~ ,̓ᷭO}Oʮſ B __vk= F)ߌD]SCXX{x\-{KU3guN}lͬF 'Q wcy g#_fmak"oded`?2z>gooH[#;㿶 `h>JL/u46q{tv&|v(+^/?@/_3^⿈@~*{";28@o_77ns0k+M,A/?;w*{؛_?2uZ #Wvcs߿'3~mMLK'iv4F{B.&Nǻ}A_=uw7}Pw!?{H?^#|iO#8}+w#إy;#`˚ඇ*\7q]TJZ%v'D$ʯwIC=+"^ua- /zqS?&j?*y:xX7vJf;p > Uثd{)Y;p43-> ʅ; Jd5/ 92e&.llM,|[)2/dI1QMuyۑ X ;KF&6GJBcH:Pk _`:_1g K덷|Kqv;M^depp31!f uqʫ< 7Dl0hN6͊hd'[lQ߲.#?<ƂKqTt%d-Ĉs$1RnVq7AC2@"\r0{y|pCJAx)ɳq]p basoj y]tםtl ܩ2C'DXe[AwCԩ**.a_Hbwz'7d (Te{?"B ]Y!;u˄7ޗuD{*ymwn|Guqq1/ _i閟-jl"ꚅݡ-Tln[ 3sWlnq~s.q Ƚ#+"=[;m1Ulz- GP.?GH΅J!\P Av չWl E>HM |o#L؀@ mPYP_۴ģSllmWSi Gy7_ձ.$Pp.`a=n # ԁW"Р'HE-㨹}Kӝ/$ D+ϊv++:Ǟ&!XZipli;ַ6X,% kV&wWͪ-K%WŸ65*\2Ǖ>dC~>\쇦i)Q4cg3?у1ZH6'I$3/Z",^!}jZ $ lJLLۚ2 a 1㟴FKDRKV;ݜC\a/E&Q 7D+ٞ8g?wisQl[.{Zf[\9u֌ݗo8] ˒\6xlX=Vب6@"(YxtVKɈg'cID`f*I`!TM9#a@%m_/~zBu3-.%,;HjTJ>wbln$65Ȟ s Gw?؇\y |^V%? Jq^@){:֝H',tgJu^턮rxb])? 1,%I$a|Hk0դ'O:~lݘQ|H(QFh5.e: " x֖_P6FPE5,x{]+Dc}CjG@׶9\G,1ɯ$8]gz5EN>B2&)/%156cV;e $`Z$~x7;b{H"N/#랆߳4C}N)I1L嘐V+6u*u&o~Y\K=>+[YcoԈi);]a\ѬowX<0%8!\q^B>E>DɠS TBZI^偌&!f l 9zjcf@%*ҧ9c<%ćd, G\ivɏ}^XhX7(k<4.@N ;a$jY̧@{<}9'ƶxP,f:{<6 EMFN9RI2uD; s@ZG S*v\t_`в竟$x 4׼Y{a8vR)D&*gMLE*c SWFt CYEugLCjk26R?LiV}*sٻyFhI#6l$m@{̻EUY^d$!~#78o12o]EY'`ob[P|Jǜ&?F GV5lSoaf6:68H:L`&yP/MLsc>gU˻ o'Hd[s_‰,![՝_eqD*NIPbQgDM 1tm'_v^Go> % `F6'u֮﵋ 7Hy:(b3PU+Y%i@",UBm2|f{eVI<ɡ'im_*Vŵ+wD [\,=_zFCI}3M#ft(ϗa9w ZPWVBwŲ3ak8X=;q,uLFH~lY8.o>;ᢽ>ƀQ"d i`B~Z"zf[ 9GjSPh׃/]No%s+Pd?[U'aZѐ&(LN0m4k͔ELw*kws&ךd!N҈Qzu˨н5x_zJ5i <,@/F5]2c!dE,,d4b̻~uo,qk'7fdu+1@`亀>Gɔ3-~q9KVEʉ>\,;Y,i%o, Q|P͹R )/IR9ѯr h2i~Chך!$߳F3܃JuK)o,@AY43UAfulv#Tg@+n(@,~5^҂I2RVg 1 È Q7g?e8yݴez!M c~պw}D/ Σ4$!fiJXAҧx fpwq۱5k*|] .9M*O5/ű!QZ%_apSNs ;j}=3AI(8=e$W=,u3Ac}V@g nvoAvPN"/~aܚwb\1sgae8&u]/{m%ǂ_Ԏa9GjvMAZ3R2>ס y|ƖfRVTHQ RN'A6(r$'N_ aI?,$z>ݝU`O . a6b]@m!UUz #`EEOQ:c<I.Yc0әþ &}z4V?GnVzgҪwemP eaW/]< kuKcMJmk5(+L3g)2OQ» 6wn9TʽsmSa~Z9Ụ-kvl>vJ^X~,-+խM؀nN9 0G/^ e0UxZؚLs`<}f%rvGDlN yѴЃߟ]]+9 EURYVW?n'aBFNQ.!.mBT!g3J3FB4޲kkJE-(G)y}ho[YB RU"wV9'x YsRDi\Y`/xABh+El'̛#ļibp+϶}Nʗ{e=u@Rc$YK{`Oy/nc_kuГn#d:2-\Tlq/[2=bͷxl57hҷm1>I S{; Ux0BA@JO3:b #DZ" $K^/B%msḰj~s3tn;"| QI"|&%3wAv8qoAX'!3#d"\ǰՑ}5z3&Pnk} r1s>\അ '(TP$JiCt]-k&^>CnD>p J{IW6%:ʹ:!h j@{^lײS)#<,voBab~̌G#3dވD\o{S.}hК$Ӟ؎Ǥ7Ko`:+Q9$٤2QXT~!x.-X~:@Ѷ./6vWne޺8z%_/aS0Yf!CL' fu/Y Nh4A:n&I53 گ&/PhUH椚 >5O}gg)5Dj3hƲ&F }9eN"}~xy+FbI:]w~1]4z*"n%BҹWle>rc̀꼱jP`mٌ}(wƾqEcHjo|G6*>i^\ꝺ![%sKl'vک'8:4J^'݇(,(cJBIfiIP VLR}`-ڍHl"$k~_P޾GRj9N) JK ä^RKx4"J rT'[X#V7 ~461o /pu]x^CwO^[)I}-.ap*<+e!VJcs1XV%~}ۿ } HQ(.@]ǖ,!;fC&P@ҥ V17*g2x#ֶW7H;+mqyk1Jot%0W R1mjx5@A܀!*z#R_&! eTV}3` 齛T5w8jlRnI)HB?)Hq̰!Ό3j/#_P#|;3hʌ̈́i|:bȾ%O~ Sk:L/KgHj[y+6|Fkq.:D"@J,ݛGTl7>yg[!;vz惞ª-LV|ްnmA}KPQ5q\_O7P@,j-2BNUM|# Vb뵌;eFQɇݫ2޲Ν;?>)1"'gZJ7~W$Ͳ2̐uͳPE\ ]E9ǝV]0z9^$W7I<969[[Wgu:DP5ʦ}K[M3M{GruL@e+ؚ"Zқ?dd㍿Wg<:cȰpS%_S 36-2ŋ{NK j`Z8`nq I5-v/w %WyZmKz 8)Z|ϫTgr { 6LX$dCbd 1Lt_LQ^<e~-2.^{Q^Ǭ@*h<>**9!? {q0 e}^F5~f-)M_[V1\COcb XbAWyEB.t#c"䌦 ۖ>RVB /65LV> L+l0=`v"=@͛5k} |cǺkNv)м uϫD_qU8v 5ka'o-`}#/qq{Ցhk7%K8uH'Co I]in>ڰUv 3W `?dMַ zDsT l~ʆ屑?27Pf}֪9 ,XX ,e˰LIHJva6 }iq h`f?x@j"r6KG!X4[렗\ #<0Oq!s0vkbLv4d[])m_~Iс^ЂxȸeqkgKNqѹU 358TI/xBn_௛mfJ~7*T}ps+r;\DS7΀N\kbw8Ϯ$=H7vOvTx?ў~Tv 5Vt8B_ZԷRV(6-jŜI |K;SٲC7^PbφyL?Buftr#t=oWzֹEW@haLu1E]nǬr*ϟ\*k1,C˹Ԑp~JgtH@bng ñu*[pFQ#_[}!phDu5>7v^^hL.V {.;XӺ8=֊?Fk0 B Û90mN@e^ 5&EZ@&5vAweFaM|ƧH yEb>[`5J-H.-H'`\M$):yqM2ՠ0߮Ŧ Ǡ ,_΢bq)ȒBާd/3~C c~=q}=hk!-YFB wD6ͪ0;PQd6qSÌK'AB_6Binl cghcJ IV(ޞd`@סn:D:u*/wW.+rbQ:J5%ݗo RFWm]6WFJIqΒ2 AROڗfM"f_m@6QG'5$ ȢaQl$mJݑl#,G?~їhXmpX쳧Ƣ=86}3HRs״xgɹ)m~-$MXVæ.uglZv2U(Tbs SQ./[LW`HiyKb?M~'/-G t7o{Qi(Y?hK ՃQc5KH ⶑ5tL:ʰKWI{™_#^IkS`top1cn@p"\>bdFo4Ʌǃiy|}ttUc!Bo[CES\n(adOztpҴ;d~'j3'lԼϬ0*}-E0j+lNA)E/@IӔ(*~\bf8?xqC*$0#c8 nj>X8<jb,%ņ{Z(A!M7+BÍ7P1Nxckt2`_n%&Q}*'zyDGъw"R#]LM/VEѫ#yAꌙLhm-ֽ )H3xA* XM59PZb dul!lX>ˆkoH?nFi-.?v]L$jjм9@ üew'϶c#o`Іl__u|:f |wHmvPwDٵZu>t=IuV`gQl7E{ωQ>?w3=sFrŒ| H3CqUHX sjzui!^gH_,}4m oV"eH%ʌEDEWج00IUwInY_ОK1q$ $5p4p6U8SXv]Llg]bBY=hH@? OYƎ  }N`hYY6TDv|GEZSgB2*RuC0jWj8v'.k6Tv#LlZ{>xTZ_Et<>BĴR*~˧:5hEhbS&*Xgo|xNf%]{~{TB>yv»_׿WnD<~;:yyjOCuA\Q/ "/'%MD͑D=;rɲ¨R$l5@>{8d!=&VM]hYs uUi˰N2/&rpn5qi"lk D\1ɑ_6GP,n$^.@>AItJnѫ'%PВ,*F nŇxօ1fխz9B[ߗIZ?H:\mv=U 5yL?Y\J&ȘH:zl8tIT8||q fmyB0CIʅ -g:Rqbrfo\;ʮieՂX2g^OqKIR \"gۊ{1[ܣέW}p],t?p6(Zޒ3 ^%&{\PO4\dЈɶ.ӊ{DG:ZbxK7i)0r@#ق+q(m5.p5uS 0E/26X/[Q;jaP'gO8CZۡR@%s+@X^OP?r)W}񭻚]T0]QkJ vO4E$z{%!ѷ>]hĴH&d>A |ll1U(=bAQWmC|ʝ~"<~<$N9 bd^_1ޑAR֝=i_rnjjyA]櫶hF k@d~"A g[px=oXZ)?TY7^֑P12sM;t^M#uRkYXe|-T'Y閽ҝ h(6gx|hKe&bYN3eL&z -Z=0T@9f祃Ê1g ӯh;edJssycѠ$IYe꽑CWj{Į_KU Řk? eەuhz&x`C?,u'y\;T#erJpk ᱆c_}Rpz'pfemp@(u!rf-l!bI,2>OpCSAc5E7Ƹ{ni˯5+vEXQ=`'Kݘ ͐rxؑ3@=&|Ю>ƹn*-9XB8 H52nOcuٵ% ha,twVΗ`FdUd!%}8^'מK˭""~4Oa>|i:ioX8ټW{BpI]Q'v33x ɕi\ZqxiE ߪ=*}u.udbXlЂƀV,e1^c/0pldlFƹˏaD#Q_/qb{'aC?FŌ4ti̊ikQ%NOoH ~LO ?8N9eROF.?2&BUil(u#;ۄbd7J~4~<]mquKCb?3'iˋ㣕Hyta+-t/-tAA;:Rs, _M`@ovdU<9̦*n<`C>*&zMKPiHakX~zӁzVmCXt#A~UKy8doO\+?T52JܖK)w6g{g/$7/ tÆdSϓS\[Cbf| 9/ ZIyH?F ¥&w&)Jæ[GLEI0hc)*e3bIƞuR+]pH [{#A=bL:gW=W[ޗ<=60,t1r$t\xOQ;S=i{؄AѸ(C؞=-B  A/PϥKc`uޅȊ 8rnS z%Hޛa tZMd0gjQՆ6"x㺷Ar~m'A5hʖ{vh(6WU9ck9"Ӎv;TWQ.-闩էK6bU.k#kWi[X(LgyP|?[<ΜR:-SކHӾ E]t(yBǖ^ j&z=}3Ylnvf|Ԇ+ڿoCͩT#]q @݌h73 M%"l^naE|>s7* M\Ts׽~.$%C^he՝N9H8QV=yQ&GlKB5ve(( - kmT]j1{oYgw9/-sxDS#7n3=zݪddv~ :7nSΥm%Z:lñ0^у=zf6 CeKU2WV/~OICS'܏IV\# /6ImD?|^6'0!Mf-> jVnӜ-6nWkQ;;3*1!7@%f6}ꮒ1_)YNl~7 eGz?q`h4j #z|Hf 7ynf0 +BWeGKI.3v5^ Tsdd1)Ձըޝ/ cW #AԟuU6aٱ5rqLXl%3xc-=l$) TL 0z_CGj+,"̯~b^ ;?*V~<:ɒ9|ȝMR>wv޹OUo8R&ڋ}n`%*k{4= H!tKBZJ ;7&&U)Z.zʲ3DecP&)]X<%~3utxp,ۺrEsBT"j|6,[MT ҷ- g8[ E51PGmRQ7h`C 꾂a0vd U~-/ p͜;yrڟ[BURPhućOl endstream endobj 201 0 obj << /Length1 2288 /Length2 19412 /Length3 0 /Length 20759 /Filter /FlateDecode >> stream xڌto ۶mۙضnl7i줍ض:Eos֬5\!#RT27۹13rD䔙,̰dd.6aԁNΖv8\eF.vrviW C{'n)@ mot%wt4pyOG w- gb}hbdP7xOJ^ nwwwz#[gz{'s~*Z@ tr~7 73zX2*f.FN@hjg t'Hv2-޿Yldbbo`diig0e]<\hFv l܌,m  .0zo98Y:8;[nwwLEmmv.ΰt𯓵w7035݄+PJ&"?2s t=L,~Wtd-~` l8}V/ebZvfda|=&? )!&'Bxӱ2L(Y|\TrP7\oG[?j?j#[Kٿ5ki倦W+bBv6Yhhbbi\X-_+?2~:G}s7cfc99y¾;bx3)!0ٻ;>Qv6oѿA俈 1O` .绥 `P޳AQ4(ZE\:?`[Lm oLLcc޼nnd - oWz{W¿Z)$ O _ﲿ2Wl|'/Έ_.ۿzyȿ{v?w_ [L:E:o_Ŀ=o tg#d-_=߬E!;#(~wrZ E${O"$y\,{.9s|/^_W2wn T&Ns+_c@ ✽ OUmH};4ٮF*S#‡d̠u[nm1%ᭉJmO>ʓm Bu}0xt{>/>-?r]9Q{%<ʗGve˧բtKff\Q.<gnnQri`}OY7cfV+T;IoPF&ɽR1KVH6mRoJf[TM<9v@:eTīYD󚚻P^ML?pdpBC #؉$"sMm.1j+K0n oW>N-PuQOjG0{9SyJv_q#w,撲'aeA0ktӑmSEjA GBlR Ʀ\**q S oN!H#VC.֊HHxs@űOLtI&^G2 #ϛ%ź_|"z W7ițEXvh{^6dq^yP]!0m(p͑rg0 Cie^d =Iƕ)]M2^ҥvr`τLw<@uUՍH'N5$q땜\cH7:VҜ})q(<)KuJK~EhSbX蓈Dv,2%B EXoR6Ot:X3ѡhlyrf2$*;4ZW{? ^,5ׄv6bno\?Jz d0L~m^T mnjzR=vHk'5i([R,` rps_4_;=wwdB *01d_&5xm OHiVzGCؔ?|%XPWXQ\Ħ;\+9WFh(h/P̢?萅 (2T9pK) ^U-88Lo؜qeHc}T34dg\W4rVE7ED@]3R+G3`Z>XĂqγ>iB%m;'9P>] AbG{<166ߺ*WgSfn<*1aVrm95OMc2⻠?Trf{a _;Eɋ~"|%OZ0ݴa Wh╁=V-Tv K_'oڝXX &g b3XX.Ngtrz I氀z_zl0 Vg}ta-PY`6vO1q,DGjWӈvp8{`hmI꯲}]9HDG1XiIhۼ8 $hӄ:ydJJsHxsA5T?IkV>Ș<7$1~6se`jyӰ ?,>vI3)]HcK ])'Ȅ|LL5h4OALM#%BuD1(fkE)hB%:u{oq^vjj9sg1oD,aaFP/RxbG$r?iy\$ K"<׉v3W8(v%Ӓ|Rɠ@R YL}|PrfVw2/=fsZ.㷂]bQjqUbC(OCIJݸ+[S902:V*h崹A>S-Go{ǢȻp_cjb'ׯQ2Q JcR.d;o):Tߟs->`jQ,u7\Rh:Ϭ1%KaASHloX_з0^;85*Ѓ^6*Tm~u.ҺϚ)V9N{:n>X;sHD0^_`n!Y1ՔnRjl&\J3 Gz΃GޔF/R`MZao9afڡo{4A 8g maSñ>Bsh z]急U> V$d1>4E'}\]<+[7dv sA㹞gY` I E.W{S6{r~f6gFs_eJ.:߶8G% I?=z~lp:(UW6qQg;]&WRwv5׿0to1w0X\/`|gNIJrdqEp~Q RpS nh .Btv)_ 0 B1cy 'NKe.؁]+UͰI6?pOSu5f=4]1D|Prý!]c%x.XQbg}Y,l Z"'7na5FV)Q61~q(P`'r‹ID@Ǐ8< U:Eni8$نr8` &Y^X3LnbuV׻ M 0I3E+hT zFkt:[H)OxqDJ7@@r=݊l0&kQEiSԒ(!Ӄ( d HX]āό n GvFwBXIݣ_mɦ\<H7BHڱ+-f<@X"li!*X/m?.+`ҍ*҄M"m5@(b@JH '촼 Y|lRHo?L+vx'CU9.X+Xf5el;?~t\!uJYNv55qa#zY՛zĽD{ k4B~H۵ wIeFF.LFo<%t$,x?1֗u䟭r.hu֯:}EixT,fZH=1LbLNLkxdojsy#u;ؠ&^wkdh~U~ׄ,о63U]QB Uu]\6Xkih2/ˋ\'k.)_ fe[o/O4Śb'%)HGD=*KZUxVSBi}w"KVd7ֱ} qۓqLSu 9Z} g }2[P>Ċm 2,w@A~+*^ OoCo~SuQY/%"NBpfX/` I<2$cMw8/w38pGQ xI7T,%AcBkBr+cef y ogNkz-PT[9] z6Ylߑt&yhK)P-"tk䕺$gFMv r .c˿}PZe᭠jИ `5km]_SW#s}-,>!N .Z=s{> ۸rf)g I0"!6.Kr=n6?[E-1ݠK콀}΢9#i>Xz^:L%1Y(ѝۅ9jOt S+O2۝Z`e%8b+}&wW^>A*Ef島%B,s*p̽|s:uM ҙ+uxW&'KX>P?][1Mg;F="M+C sU: Rƫ֥ɍ,`BsKQs*߶"vU]M3כYg~zؾo\ LYKM r?BJG'r*- #t#d*%k) q%"Sz4P{~UHeW1rPEp/F#fԈ9„"Gf֎]\^RKf2^-=p MÑjob|G#B{h.Q5o;*z|ۧTJJE:%w / 8D_qa}[i!sY mcSiiF&1f%x)'L2%ގkOtTIEnkv$`vBC/2xX&#[Bc >xP<)?c4hkHF\pҩ7R`K ,E.51ajȊN8vxH2 RσnJT٥Rm 3# XC;=CDk7.fQoT{yUT=wpŢApxX.Veͻaf&- #DVvyǣ[go-MN_nA_= Hhn/*N:NYEJ-h%;I !:%1_&~'S[ r:_9v`dY5I2~;:+G?MRw7W)?3'ՠu|,xuY)^(GbUêsƙ2f^T_/Ru9^slri ѲX$]Ne?6M4ZFyvR89dv-Xi^ZΑڵD5ν{e蟠6hADp}j4 u娓{SofU+W[cnSzGTP'aۜyypN7ȅ:z sN91TB^\j^[s`=@-?;} v2*Q֪ !j*Ʊ6o[T-IQn6Q +#k^4iat6v.\t4?7ÑUfD1hp"U?WL Wa-j!E/t]MHCQ{2)i#GCPBEQ\,9:~!ڮգ ,H|ԉ_FdOQ4]={t1I[hzmߥJHA?UpMlpZ'bv>G>2BYUMx J[]ý2glYV,'Dzz䈇ltF5#ںh#2Gaj3{">lEX 0 RIQpg继%ՂL+ T̋EWCŃbijz \0暌CBHv+>;ǎ@BMw#,n685adXEwCBzBsi o&6ɳʴ>:;)ksӟP2ZGBDmB=X 8bV-m'x\z\tb&߮0r0[ߔaGoh>V#ytۘ%+U/\#9ՅdʐDJ-Սr}bS''*e?_~$[vo4w9~\)$_gcf꺇5:kQ9?ZҔ2Q7]S>g#e=3`TtߟJ6{S=(!*D32$vX9aFi]wY02! -.Q8Z,Ab3 K6'ߎxlX1 CAhhp.TۚOM(_c-cߠ 4јJa5b΍Ӱ8bږi#~݈1+U0mN QДÛT~}`2 62Ϥ?&T2ZgFuGAvb8 "cEj!+,i &WS9Ulq&8Qhf. ֹyQUmduT7eY5}MH_\f)rڽZo]di(=U}:ΆvK=A O6=J ΅?ko8-01_JU!ʴbCyrO5lUՇ#2x G3c2ܑtTZ{N57R\{.+7WdLөj7O=OOa$1gV/V75$" >z l/'{8eX'H1V.2 NO"9[DUL2X Bx*s9Q^m"s`~4jb@H xT;U: L)!}dƕBԯݎ.V:LϛȽ?'1fPxDEыTaDG4s]0?m{PHES]-Z 4_6PNk(k.`"d^ _A8 k1ϣpzwN33IK3Yjۀ4&'-mםOjޣj߂H] eAo%%1%% ΨzِHDaס\ ?{!H{ tǭHyKPV䨈qGeGg5R۝7m6]heI|pQ%+K$XjF3DgNsfe vwazr36=)[F'"AZ7EL\Wqu u+BF|,y[":%>:)3(G׻:oUr}[fȚZ)xQJJAb&2bH,3j&vͷIfd)DB8zoB\{苀g{@=-AA?3xQKI#z|wNWCǰ^?&: 11+*T0㗟h5ĢϞqHi;cem6@OxTwۅaj#L{R0_C\YK< eӺ-0'8f3+*%X S5R A ?׆>c.ĀЈLp9 uY@~j^uEpx vXEϒK4S-%ӆ VG_VQhP@ms"jDj)^[OYKF?b{(c3aݽRkilTGKC6"ohpRщ9@Li{ǞbH|SM 9WS[O_?d"i[5|;dda¹xׄtgYyg$F شT(2sHup%{K.Z|"A쀧Sxǖ^Q#X_Ƀ}CDݹ?ӤX^klE$x%Z1R`Uw҈RhIh"60a=I̻(Ǖ7~G =%?_.^F0Ye|FFxtXjp9HҬݽ\@K? z= Y&WɽCrFg7zS6GD"gľ FǡkTXDkIX퓜'ӄ/`!sԽoPDKInJ-%گlA2_#,fl7!_,OFۈavFSV!X<^UĤ>H&^ Ug>Tɠ)3gpuNE42'Ix |` BNX7Fift+֫4zb~p;IZ7ۿPx^=nM(ٌFj ybaq(SQfJA&<6B*矖_f])`,w-u(` i0OWcbB ŲtIHH:pyFpmD?\ Jz=/4$g ˚HScȲzABu]}g6 3cuZ︅MKC1^@1PL&.GDž|4JE!қdzSf'yvF;}M]|h|@gyakrcյS&`t췺(| /SotHJ_6ߴTVZA$ۯgs'QXTu `4cM !LË?s'L'Tj:qtC>o> 8>+R:,l>h.{l.&w\4rn))F~ĭ?/d$oB}*JzH]/Nf qR5IcHJo{(6|K`z`m/Y@2IO|5"lTI#[T^$i ]ZH5fSB,# l%lvٌdlΫ{|\sϞ6{4փr5GYK[@&nRL=zOAPh"?wXA#7Nei-bU谍ڈIFeYhns]Eda|V?9,a @7E>]6) ҍJu&?kTnڟ zgӔER"C?SÁ%[uRhX̦VؑĘoKQVR T7N ;pCܘYSgf1ARo0~JJpJTPgK¤#ʐR˜nAqTx *%8eD6m3:ɭqv ޙ$ẕQ陲5VyՑ]6Pz oԀ1Uh4AFU딄 )}a]mB{lN?h'8 !E}`<{uF8w,܀T"ΏŌ[zOcBүvnyNc[I" Q^=ǻ@ R˰)Jٵh yzXb4Dg2l5t6JXb"FRˑf [?;&^^§@i'E̜<nH`.e*) =N=NӣNb!jfUCXVcJ$GeϜ;wHWMh^5i lX='D{beqSf$[}ê$1ۥgCs(,`<$<#$6f%_f8YNe$Y,$g@ I,Tl;mM=sGϱNE4;OjTEj2|E:hڙ=٩61,"$b_(0uwKqȠ,#%o0V@m,j 3Jv&N0?itUƎ@S2eף-rT8n%g%VԼA7m7J/j+ ۿyPʂ}ٖsxL@5at1j0O)sAՈ%WO{">k X5oN%Aq3OܡҨGKG蓰|b ikVq%>\60uY >4\ؓqC!v4JnE,Q),A-눞c"2hX땷,R6]+,lN:ӯE "<ě|`l$\L͇қކ%EHž ߘSzSI"2[`i5i1Aٌ%+ l8ޔkUŶhaOo=P-$7zEi šf4cU< 1%$Tqe`Xn䳍z n~ٲrQS* 1MM5vOZ|z* $t?8a8G!}2SwmdEWZeQzĆ\"< +G'KsxH#'_Tm;_[AT)+U.sR*xLU&r6Z4(Rp>zWy1\ɪ)IPflp|\/# S/?zTpFMo%)y kq~,K"bn/j{7|@OqMl﹖e3)Yu*bw 8U= VF .!i^L!*mҶ)$EN]q eÑJ3gRLGn4|B]&)Y>XjjY̥-V\Ff|MC2Y[+'|d'qМ0QN-8jqsu.QFz<%5˫gO8<䮒LU{E,1PCT69QArޅ|(xQ]R /OCSg K]RBE8'&k8nD6M^0QvY2;#At)':FI+Ml]-aq^fC%<2O}51p.C"9϶4܀p9ӈd8ƪ0"g_B W$FEm[&!@=ے8$S$l[z:MuT %&٣ =Ĝ_P*J %H =5+.k/tq}"pyMw\-jnp+B/_ý=}.Q/܆,&RwůFBUw4r p b gפK ,ǀk&0 aXr2o~(ЁsRlSKu͑)N\|#<;.gJwsD1Ldj%Gs̮І aFZ/]7V48\qD̶nhנak0[oȯhnL³!,xf蚏?N_Cu]cD! Ґ~jbP7 V b!CuDT\%JuۿR-KNL2F4R+d~H,&)=@~O߈;?. &])zqeÆ%50 ӃtBh{7>VN*j`[CY9˺}Q;\۾hnr&,bz CX5H q6?eAh#Knˁʢ3 \pwӐRs.KaU!rrgk[8X#זBXbxe}_}vcgb)]BK+gY%4'LWX iвf7UzApbc*Hg+rD$Q>+stNy9`+?!Gl\Qla-m-W,ؔ?r]Yr(Ӟ `4bM(jaa>(']aRtV4meL<(O9kٜ] hR5$-X/;QLP.#펠G) K Y&3TyX^ ၭ~gjP&uޤkNҨ)0 HgS)dvFMG~aͦ,~m6k=o8#gop-kuc>z?]8Y_3VNh=#sOR9P,dk(\67(fF8  >$VFix;z:oPqv虣IwS鿇9W]& ز]ŸDܛJ|mS< }vs4F nJr Cq&(n~?*q'\euŅ'eY$TH _BkY.s:SAUOs_j[DK2Ƨ][*&Jt Qx.eEN0PM2bk,s} 2͡T&~S%dRs}f{t{."QD&H-Z-"Ɩ\-y>cQGӉj{-lsRd/,QPqG;lYX4Wy\ !C̺>Ȝ6pMgAKKC=( .v ܯZS"{I<7vP/.ol[/ *wݡfgr!f.,w|7<ʉ kPxHq(L(y={ҾNXȚn9" MM7>Pj˽Vu(r_~ˆ8&:dCqvq51&Shfu&yy:M(a&aHLD)i܋Lyp(fUe3.r[xw9;0L}U>ﹳl3m[f2DB]/0G(\!m .- ӃwA14ˇe-ݥ޶>lL՗pq,ux >}}K:ZdLb t&8=z8{ɀJ,INf lX X0C4EZ1u9_x:8d-1~F=e˝bȩm!nۍ%4 HiIrݖݘN>⃎nqHtdrXAH!lTgo^&׉C:!]bhD?wHO)/(J{]''{xG`brS!gb~+ ݉䚂ԳC37I9x`$^6@{iI*QC h(J!rwV1LU9ү2vֈ/|JԂtsgS8w@#%RmOpQ\dKhsv- ROt<\j/5i&=?W -Jȥ Hq4Ԏg7<ٺ L!n #~ MEC<0`X XTcOJjyu؟)q. {"tJx2qP.Μ Sbf'Ȑ"ȡn$˅K"|l?_j'_ ,QX+8 Oi7olprk0{iŊ%`Ʈ_J @C6&W^@%Hv٠YֲKCY!iApkt'#e)sfQ#D^֣U$=]q:ƙ0EH \'m> ߸k+f|.jݕ'I.tV]6A!fb7low0H@\i=guԂW/Y< wjT=b Ob Ry>$48 Rc-kc䠞MA5V\F!`KLFIx*rziKkË#T!n( :_X~ځ<Ċfa]ISge :_R8z,$-]/ZTn#;5bGZbS[}ss,gCV/oklDrΣז= HixwGn}xl|rFVCOJ<#ok>8 ߋ9=Ȱ _>˸>N/a=S&> stream xڍP.K ݃`pf`] ;N ]$xGv_^M3_}O}`唱Z8'G qb129 0w(D_9ɃN l 6pև8yU<ف!~ ^A+`80p߿@5`s` ? 0y/Gy@!>/s#}c?;'+ q8yaa ࿳hP- g=?_ \Gт,h,7oAY g?_YuzU=9}`-bӮ{ɜ `-W fY;=~\>Rb a y6`?4 @!P ?$V ?"7=?:C^-/pC>>r?s|<_nAA7J{A~_ Ex`o5,Z,ܱ!W θ4a+=MB&u#˹"&[$ɝvO&e18߹8!GRew*$է_49V9mg~܋/lD?g/&hUر&\}]u~ԄhtOv/Mlίd 6I؆k/9(Srndqkm.th9?U׼UN[sh&;0+窰ӕp~Mlc A\^ywEbTpŬ$2NGtô{f8bO}L([HO$]wi!uEvVNmx]оz]GF " @ Q  8:aӝ$ǍDRE%Sqc{yH% w95א,zKKIm{qݗ)gK-q=ﴦŁ*;+}Cvu[GOhR ~hUz3_obtǏ!%@w@;VxѮ^uwLS/eU6E=mnMv9NO&~G) 'H}&}31.}"*Bh f7HhxGZ&lVdHpJA>~ȼm4nD{u.$Kk!=,*w-hO:v;"פtfQ0)6[ڵ__.&Y ΔzQq!Nف{" -ܸF<(>L*,j^;T礮_3 t'2qg7NUdF6huɕu*tz ׃I9W_#["J!~5*Dc-?D|);\UK5)BU^h뱚=2癠),ATSLޅy4&gYZx.?*s$:@XUOTz3-F3Q}(tB rGe_ 9\REeS5HbnKq2HY:$h-s]ؽS=nj"^*S{\0u!Fen$}k1C+ln6MDmr )]~=?K=bM"Eʲ+$܎^+Z!4̝RŸL.z:mvGtCm9,.*DGٔ8j!˥ #^S>#XZ1nh(E-L}gG|/ցmSֺ<x{qz-!7XY,nq !: VݿbG"y=jy);7C@:ߚT.rtNS&)Ȏ牊맧bh7G3J x78ɍW*dՌu,4Fg#_M"Ε2kiK1Rzس띓,IOӞ~[tbyRSnۋ/(3iâPMF]&Sx\4jr_1ޤ1d☋kJ'cI(i5;}!x]ёNreun wan1Pt Wv ;Gg|=ո(o |xR1KQ]"4yX *FʳXc]5}`_)[M8+D2"̱Ko;<|0Jxg&Ϸ?G -=:̜*X;߄μhζ~pÛx~~Jnoϗ>tׇTjO ff5vHxM'Q3[kDm4V 屢F|vҵ-5L_ކi"يx0`/NZUֈ)Wph 2<ݘ t.l < _!`hbpЩ6|1Z,3[z\~E#p0*E^I_fZZM- %سbLy 9JΟ>i((5Ya g.,Qֲ 'EQKb혆e{iV6ēl zOW=D)-Xf2eg R'`~XԺ1xZ02lɓ\#,Pe,ϼ Tfš%~=-1RpMHƾ:`fd@!qA-{ͬK"8 S* dp@z:OBAXV@x:SGI^A-@rͼ 6$UPD^%ڻ0{oyBMgtLJnmp8RO%u-?|ӯz~G%dq@uBl]vbVjW221 ¸Q*as!5g3ۯ*2*Gx/(7KJRA":H` Ө \0ryǐOMA"];*P44\ebͬi9Dw.IkF]Ai[WO- SBY"[Jj\`@V\C?>x7S#hDgG2M",$Cg^CyW+0q{hU̱:ϪMlLf pzZCS5vDte}7f蚳x~"ޒ/Y[2hߟ,%RdA G͈=rO4d7$D$ ͽFYPCshzdyg* #ᯓ3b*JhBɇVQ S$NZP#rq|z3xOGc<ɐπrmo;=+w2/$Hɍ6fжU[zP$$4\1^ GkBk0'4 @ǟ$c(zR hc"@l\x1pfGO=H Mg?ު-L]vG &MsmIEn.%Q.EuThbP_.XY|yt?)0 ,=(Qʮ3o5G[ HQ`]ڵ}@GEtֿz6>fc(G@o!UQJiZtYn$csiLJ2pC~EoBCƭBFm'£nK7|G q 9B><9RH!ȓC\C IG<)cOXI$5 Xqop4 HQė~1dVv&.=U/r(gFyLSathӖV-ZQGRQݚEs7:c^5l;󯢯NӀoq CUem#REBwVof@̧90w9F"%[6m'zo߄kUׇZp.g~=+wq\FB蚳2u{Nw0~( EP1Pu-~\4/ޝ\z>ֳLNxed8<WDD9arixkK%PmFbnܖ'6һ:f=R.R߼y8PJA}O[1T6=4d!6L 70 3gr:bY uto/dD]z|=#ۭs,R~QL&w´H?څE艐\U~Z)Q{ l"AjLOMVbۭ-rF[3WWwȝm;d7 $g"6iIG[L4l=0햱_eް1 '~u,DaIe&?hf;2ބ6r\N#`=tv4ԥDϴhaae\=kn<\4aC>65gܻPS@^\$b~f!Rsm+&`ucoyaJ]纅2r\L^]I1´ڱ6bG鬀+g6=8.fș䕼-Ia{+^u$p5N xnךΒ{t.Q |t ș('nD?RJa&=x2} cuw%SO!+aSNW}x/hefs杚^o5x\~FjF.&Z%:A98qVh/.2")_UȨU:4,լd蜪2)JR9SO9S' b$A\h u -gJ,Vq7+Λ#7wN FP女?Kl%Yl 0TL>_|TZ̻T4kFtOuՍCklw E[L#GIhr}e_ף|6pJz+-DfްTwR–0f?J wxVT4~oylUz6znH"FԦK:|2a66=1ΓMpOhhSRo}ܥ''+%|WR`%kiIv0vv/e9 e|75mx}YEiyK:x,ӿ\@&i@YUk?ba8w`YE]4w%Nz0=edU~!룗/<'o؜*nu|Dž''sA_ øBt؇Ȥ;c^MuXj.z$۾p~iRirEߓםR|&@(FH#1lD~"G"?"֢ 15Y "tj7F*'NjN޹a`N."AkR*;oG7Wϲ_0Gx_`9>ut]kQK> 㓖`oA4ܕo[&܏0M*lV`RsI oL%r& u};#ь挍D_𶒷i&5!1@m/|#\[$𰴾U4+n#^S,+0H5!~2ɲ́ Yfn:8GC#.Dyة3<kAV~EV,]*ӫg*bS En_|E1µ֭R()ue=߸ԁ"X ٰlǑ-0EGxčNZ3)e<}riߊS0; _öҽyz֟Ԅ0q MU ~9UR} j6%bCZOfH7e@2˛%Ʉ8 4%r1f.9k}2:@`avn RAElLa$$r,OC1 {xk }^w9՝HYNEӸ-,M^mzen3J28fYo OM7F7}x!|oCX0 G..1W)eZخel @LBn\*ˌvE-çz[fg}J֏^|(Ib`:e*P ] Heszr3Rfxxԅf JTȉَ)yUgt47C;ga'}adJLl2ɸ#*gl"P\RISZ']԰gdj"W- NvVK4`M`܇Ș#;+%V2ΡZr^ =(CuxHIn{5,Ja֚rlMc(7(8F-P M!pY'DeCSi a*.?a¿fIOziD F]2(snֽoD<%aV${=aǠ67z^:Ǣ(nq<]Y屮àfmڸ:@$Gq#Oo})&O=vfϔ#(&Io {L_z6ъ$y[ܜ̇?(#dg~78KO91Ze]MXB-yu{os3n7}weGMboؤN1qcd)%p4?פ>OG{ζN=]ƒ6 .Bkz>Q;33ܛ&yO}˖*~_lY#u&1bnM"_ %;Nˏz(h :f8<~앧*z٩x_a5wi3WEc63͏8VbG@g0ԫ;87KA,w|E3ڙ3)ADtShD9>sH$!_*9z?9? KwǩVwidt>&lB%CAW|6wq l: V^]T ֐UMIy$0ė![o7|'e<_2bLl ^ cWW?Tvjr$nM#>ͼ 8e9E*BJkp`p;ީ %iY!u _clk}[I䛑MSngUTև,QW Bv:'Yϋ.3L&V?כ6]!OI$J?uQ?gzS2c5 ! (M95“ pR5`([K -WSo /@X_x}{1B!KzI* A`glxY^I?yjeMp·1Z(ɌoVYu)wtّ#߼*N.T:BKaCE!Rx7Nv - R"'Qƫ?8òÉfM wV#o&( Wh%N7!r~Eb)q]"]-_NF`)(U#Nso5+ȸMNu/YǡL0uwy8GXR2c6ơ-ٸ,Ɖ֭":i@fǿ;WQPM=,sHQ) Ter-|o\]i:BZKh┯( C^I[ˁ9RIR:lt] 鲞lHT>UȦWl=#ʇ?! kR崸#\p"xCLч1w#aHDKXcBxNl,\͡bF}ƶh9)l@_X'a&l[REI`xIҝJzߓ>> c>177GDbq (BwWňX#Mg5PmnLPmTxOSֺBE)Z۷0k& fF!>yҵ.{ff8#d|^qa? Czgv"Z C TLYm8_ -UĞ'/67* Gg5~?>:! lZZs\q+`Zd ݼ[6A}Z'P'#ˎCЩ.nPjJU؉aBhK+מkέhjׂBM9M 〼U endstream endobj 205 0 obj << /Length1 1771 /Length2 11238 /Length3 0 /Length 12358 /Filter /FlateDecode >> stream xڍPX.ӸC][ Cwkpw\ݝw;si(TYMRv.,qE5~;;+;;'  KDtr C/4qyI)\.  ;;]߆N 79@ gotFwtYZe@oc f tM\oLu{3Bпrqqdcswwg5ufw| pXԀ@'79rJ&? cEhX[8o0 hjgt*v+e 8X9_lbffo`b X@ 3C lbf'q*䭾Ulrpqfu0o,ig.nok sqF hvl]4@@YYY]<|#afGp O?o}o%}A$og7 O#$9` !M u c< fePUWUa>|xpX8y|GQ1߾vȾҿ Z RX ga7{?](_>R`Z?-/ۼ;6uU\mW+bbv\"Y 4WY5*5X00b Apml yS|[N)igfovqLL'3Tg}ZsK%I-D>%Q(^mj$^Do>RD ]gG@fN9\GW~4|;^iѐj^yih(Y<9J8RF3/rLHG\E޺1s^]ԄXSSK֜FS6l8^;JjwN4l8Qk-2 % pg+rk|ͦ We0_-QT]Z3nԀ*_,z.Y7ޏ9GpH+~ {2N`!DQzx6ǤWt⋁h;Y:g_ĭ ~p>*xJfʸM_J}dа/0DJ!WLfrf`Yڲ/^&2tF)Ur A;Z'+t|tD]tr"2$96b Vsm â*AH+u,3OORfAb)sr/ŁQ,ҟ̶-gG/8ƈ |5h/{e=8xkuXVHq-MyH`,T6 |zT~6czTMP "Pu376bUWpT;(5Rѽx*_es]q=2[ 14_L}KZ0eA|T-Fߋ(wz$< 9xt"t;Hn~q$A5@@-%OhKtOي@q}C8' (h,˜`R[$~v'pv2Sɿpoѱ:Eԋ$udI e9jjU-8V)ݡs+B?GCAUC]gYVMTމKVw%7MCB) ΈsۛpcMvۖkc"!zjW&8rf F\8ƗwGm si-"p~_z?߲ToE(;| Jc:TlO|fI"$і2B3O/4r8Ս X?wgF`v>O\6(b,w国p @<5QLT26SF~n]g;\G7 -DQ_tpsI*Gq}p-t0;9tRՎ."<ȨNetsnݯ]iNj3P [ !qgCC,hX;޷mFBC^ kw"X?*N NǾV  HN@Hw\[c^v/퓚ްSO8j(C(t ልfMUM*%^+$WPh s"3j5ZCd*i$ `ϑ&_,U'3cwSKW΢>?H(b`o1MZOWyuXPZm-ik]Y]fVt;.vt!ܽ21FI!AZ|~TK2g㸻'WK7h|w/qg{y< "XC-{sE4#KgEt缾إ5J~g0YwXZ|;\YnZp0'7,6"QC3 B s+c]5k+6lޑ8FT9į9@}cMplH-Z"05<*cʃ:1j#!0oZxC="q{}5`L'=X 9a7"'?l+D5n~&qQUՂ>-%$dzS'Ǐ2|UߔUp!ێC>&N0W/`7IԺ_r䌡<*!Q+g؍Hˣ>!/ a^XV78re$L]޲"1Il2n}nR!z8r'.Ea -Vl_'HGR"OЌtj9hC.RFZ,'R1B_Z?΍"I,H0Q&.fZG'-A6@`EVRb:_9;TW֩SvLװ }ɸ;`OR22$ 7nYɿvifXMv=!Cbë<?QxQ|[B/Y!&]J;_25آF`eC;Ӷ(m;zK/qg܀4 g{mI@a0lzn~ mn6aFAX#tIYeLJ$} eVkN@ }(ˆFGrxwuM)=J"H_QQjX24hal6HyӍ eQ1_Y]ŔFrr}/r567:,piWQUzoҶjK䰉W}S)LXA;p{kkn̈RʍF/d !ٗd|33( G$W͊}|`wjpVd*`1~q,gucc;dƪje1%<=\M olS v|>^a d+0)Lkr\IFrCc{>?K^׉0 '~۸_2Q,@o٥N[,M~q@O~"pGn½WmrLzCqr'\ kJO{):#I??Jys嶑k=e\>aQNvh˛#8: l#4lܓb }G]8|`{ڨ]kǘ'Sf]d3>FJZ JhZsoXcp;Ɨr(!ZE44uu43})hZQcHi(k`u}yMD$^jCYV*=y* ^>g:$|:xD*PF,VvˣS5YcǭK,LG\ & ci;&fģLI'g&GHɪAc:QV~Ti*BmEPbk$)Ѻ8 "D=So 푧Tb^ډH| 7J)<S&h/?e&xWy7^BxI*Ŗ2d"bYVBTUMdz v6rQ5jZ|;"W/4P+ wʎG۲{^B,:OurB#F)Ċ/1v[3󙆢*0]}׳D}=:$%I|2A _l^a(r>N|]TsHѯۥӨ;-\k/dqK8C5>:LR-bp+(n=3q>`S4tܶ\!*+vzM e'W~m|l'IVTt")o 9CfńdM/ 7|!J..#-L+Lb(n?gU>Ǜ! ``;yo} J=Dy*EUK>JUÁmɊ;rPwT4/Ldk <ܹɞjT1M1LW4 =N;_j;j?ՠwn ~ 4^TI3ӻץ `&/7VM'޾)^[ k#NxTJ!ljWg?UDhBfzTEQhf &P3t6+Zhl\_= ,/)Z9LWJ9 FK,22%7dz"Lژ1^ve$](66M7=yA.8a/׊sһbKm]\-TtmsNNfDOʤQU؜=Z"VjN]b;P7>o qFb;: wzZԊnk˿foH`W:Y~|dz.Nl ->\P;L1~O\qg9zڲ m?2hqDsEook:>Ҵ .1T(~QNz.=j e|Zsmܡ:^dm3MW65c^/kEggތb!xc~3T4l\{:ǰL+0[yg#,98([Z '?2ӡJ)*wtYc\Z4>cnͽ!>11y)$qh~f!o1˿Z;B匴@{\ZLo[T/])șd*Dxg|iX^J^( ;^\AGP)C UWP gZD~h+n,a*7w.ngiZn&ųVA([ʕHR;'m!W31@4{40ZF|!N#+CT#,0Tz힖(ޯ8d IMB_$=nH.JB|-T/qfwW&_` ~?TslXF#c/sϬ"BF;t -39Ԃ/)뇱g+WŻtB+g3t>svGέDkH[ j#[GȘ wS+o9'~6R@"k]vk֎?'Y9z׋s2-o OCfl}#u=zY.3]'XՋfVE/JDG֨No &|Dܶjmu!H^T9!S_z 2(b:2t;q+"4]/$ w$5I_:I?k^"GȩB|2#N( Q}sZ:2䪪߸@ŏx!ks/)fTTǶEPy)NO7!eoE$)ؔ:Kxt*"oFrLCj>7M؇HskP F i#B=[kzd>J+KDŽR(4헪=.=^iϬw_$3R*IѨtԘ"$9"l8!3_zJTYHi<_k m* kwЛwј1ȋs W.r:yT~7( krbL3^&˕뎁Ԛbu*Zߊf g¢-W”7b44*iY 1>Xm5cL~л䱒_š[ԀSF}-]8/,^rfDˮWJ+aZ݊!l #՚2R~|H[aMk-H_׮GqD;$?B36y.̫RDXQ6|D5sEՠi̅D1"(If6e$x9'Ӧ9)jVdO-d3/J? H)*}Zh#^78XVNt 2QO<Luq7q0N'Uߌ26v+ZOx S|#ӕJ58w[iP0`jp\8}Ƈ7s%2W@u*dh~VAI^8٤ 24X2+v66=vuWb 1!~$ \H*xO%!}uAf\4prhW|BjK<Ŝ#مʂ |H2F7L|_02+};cJDц7H d^Iږt-R@တf3XY0 Gz"bD}9 U׽&j7ma5;:ݬEН{9AկV#+X4)ӠT]W@ses,pㇼơaP_΀휮ߵF $dnwՉ>^;k$" raT%BJү\ lm 'F}wﲰ]d; z<}*:9x,C""&1 @N]_"8dNٳ[ X^* % ޺vV.DNYjr"19\jCPlŻϰm }\jD+GR 1 tCTT@?lmsuf ZCM[\:(=j9b~VkhD|,|̑rX`\S$26lDܫ[:U8^.u* b=阣*Js@KRٵ}h~TC^j}7 #-#O]0QZ%ޥ+1<ԡIM-*F oե~}*‚f]V}Tjk?Z f%kO򒋣0Hle@6"}{zG \T郌}!$]qo+!WߔXyKkʐ ._y,udy#U`Q˽O+jH)rf yR*dי0\li,ݐamM$[]7.D XԩpG|K}_&JAIh(n\?Uٹ3Eϼr^|a;eYO;#aĂlǢgPC?_  2]<#t}0RGƅGJ QCl+ wY=;мdc~Ns[zϖCzs#, Ė@;X-LGbpfq TpWuGU"Q=U')?e*i7ľ+y}%ZmEd;$+WީS&bg~$[]s|;,r3,*k<1ڶ*s.XsU/GƮ0]md` Y.I~t׶E2~?ѓDq)UK u5_|kh*~ @0G% F1kۦD"8;X ,$79]B=OodXtըMD#ɠkd*Ӵ.&&!?~ LYʪé` yrȁ%\;rdqC< @ݘ%5&%WSjd̰PCյi$ N#o½D/tx0JpO"i">S&&EXtb NLAc.ko 45Y;'8Tv^6nv9h [XM7GZ.C7`%+,~½֋H+DZFlk!`Kw!nF;E53Xdyh=0~Uen[X.h M鼿?`#r4K\7[kldtDL1Plw.L=QN;{x 6Ay/ByYZyJ-7>Piąs(/=Te$]ap* uK]ߑip ^.;@2jA{C-jL~ZߛZ|X+ngJ/(o^c6v {+6.{ph #0x; hWڶƄc~FI1k8q4x8ji:T#6k;={ucxurn5'5 ( j#Rqr1ޕBXJ)ӭl@f]\2:Y߇n5xP:l74 p5/KOswu'3sApiX9)7|vri6ߛԕz&>%!r6*[:sf>.y3_Y":lLk Abh@xaLC'5ZPU|+\$$ǘ8JjP>hO!?Z>m:& l:wWOa /( P"氌-%aNs{xc; @~R^uGq8c+}ʋA xߊJ~\p{S&a"w8?&к޵ֻ{uJzuu5?RB R{>Y\ L̉BՍF6o*oK!\\P$+ʫg_a%{f*}C})- =L~֕ڼ )+$o^0-xBG<ڝDJQ%j5 ma?`}x4s[W܀R1{S*!%]8`Hc=ߞ* +dQZ"5r endstream endobj 207 0 obj << /Length1 2634 /Length2 17346 /Length3 0 /Length 18879 /Filter /FlateDecode >> stream xڌeTs<=Hpww ,X9&1]]KzWCE(bjg ufdebɫʩXXؙXX,V4Nv|9AF Wy;[5`ca#)@ cg tBp4pEZ+//7ÿDl&Fy#g (5@?4-ܘlinh ]6@OqLT5 K/ڙ99 J큶v?2Cݿ,m`fi (J19;3lM;Y;فYZ@BD`?:8Z;;19YZ7 ⶦbv66@[g'}t:[ڹzffK1ugVtpJȄftpX0a"o3/{;{pvtx`ji 0["af 8ZtY@"d?}Ll=렙4ĵ)eQQ;w#  /kߜ]# -@h]KY$bm/3;GG `m70Af? `EA ?a0+Alf?A0Ax(E@F v=HZY@FN&36c`mI! zo̜{JYu "3 㟘-66r?ɲr56rşAaOP. H1F650taA.]@X)$D { _ _ ~) ߃gݿ*]BqlA ж.6ƿ;(@_\Y9cPc]* UU;g_> _gU7yN)'((7'k#'(@It3;[8vg768\h__N&v7tAPF_/j矜AL@g?w#z@>Z@w ʒ ·ZB7)\wo.1L xVey<)Y-u!!C cݬxE`10C0 "Θ+!]\|%HK9 ӦP #~9ݠ<ܝdWpq鼤F(S8<ډ"Q9\Ϭf" Qwrt3D8M}CKL0/y)@j>qrx1]K`ան A6g\[ ϽFedf2؛#SiVأhs7H%6}DtA v$ M#iJ!u10Ծfkd^I9V͟Ka`X)NPp$4g׫ZCik%陔pL"tXy~C]M04cH\t{.c6i bIV_Jw-d$85|NSoѳD[|{r'%y}jyw!~fkrS6g;.yMƝTMoknD<}2P2 C S.b{XՊvu8H BB@J׀sy 0:뀋Yϑ}ujL|EBG1n_I3[o/DR[8&a^u.Gh"NaT3,m*V\}$];Jl\)&sje|$Pr"݌^?NdyL-}ciL޹! v*$AO(fZpfBػpsِETp>YZX1ϋ^K7F}P\RU3%cyh+|[!rqٹv̎q3irXWs󱟛[>ٚ2ą_h`[M|+D. myLݯؼ I$hwqV{9u8)u -y_H7p1{RTP/ic|gnllNP 8&+ ,ōpޢt->9PW|nHN7:.+IXWn\vUךEAʌB`ܲ3bj.P9!7;7&{Dau鼀AE(GDW ̑P,eF~f,wPC3惓7& Ic.ZuMn-:= tg2jнLF_J"ꃌBd7q$Nֈx?+E׋2Πj,ML#0w$eOA޾H ´NEnY>L@! դ,H 訐" K:%Je/qf\D$J/dGcdeAw`}@@|c-G N~U 5h\ 7.~v~LNOٲsZ_kpVLeD0t|5L;GKQl, m+V+a|p4zk]Q>b4y~!C:Y%= ^`[,wRF[:a\\#߫swg>.}dbDUܛ t(Nwһk{қ^gTM. y_%$9c"^F "2D-'Yh$JXw8Y\:/O qwŖvC˯}{,Z=&{O%UP_&&ϣ5߮kt:]oG4tnlaN)|}tZ7fD,p-I,!_Ք[Џp,a ߬"V RΧS~VJ$L|ѹZ,F1n3O*coRU"$vƈE i7JS~A!@Ԑ$W%@bl3sX6]y(X`o'^wڐ=@)A%|MKAͻ飚,n/]\?فD]$D[E_ٸ[7䖮 M~V0걙n_mr $1>6sc/e'7X#[CCâ!x"SwʘTNk6U=l̃ЍKzfbI]Sr71`O jy|tv)BbT!>ź׶:Ư?x6򥅽/׹[{'nYB0Kѕ4rdNGM!1p- oȴ4مgY0*0vMyYH ԌK]R2 Z_K5 l2@) k.zga4ע@RG^f%hh+*rflG | wM&a!^ڈ q*|fP|Ж'5LZ~yB`[;;w)}\/uJ(!sƚS"\Q׵|60eю=O"$!歎pe\2x3\ Pk@6NRc_wm5ֶ/)Ӓ=dmTYػ5 q`X7%ﭑۓtg6+ 430ҿBxતKcn.&r@:<\-Qٓ˦>jw2~k&' Տsp*Z !EЭ:K=HY@F˟%!80Nby=ܔp҉[[r]r 󃜎9b|G܃S3?:'1ϝ+i T>|Gws4i)shoo%yc Ftro@㼛ymKciV9\uҭd۾~?_(LAV; 2/G '|^P >੢Z?J{C#7޸h)6+c7^vTR> O\{{"ƍ@@)4ѳ<́-_w)IA.1lA`^BiB)#wFzs,_6nb3;pϣ$[ rLhđF\nIZ*R ;K;` qw`cq!x2-70߱iEUd:,SngS /ZCQn/.\ S @Ť&ZE_!@zM%b5 89yߤ@bdsy|O>_eï~"8P'%Ԅi I`9FWҞh|2`MbC2 Jj0`U[!9 ںlqYFX@[^d,n1>Rc_3o`Y5pvG\D ;m!PiB6Ss"X1ٺk[Tf-q=~RS,K0S,~OSjrJ Ӟɨu\JNs'dJޏvxLJ} /wgrWhj~s3jbG(λIT9Sgh/tRlYRֿӐ-=vw4\9಻tAP,aA )yT;|1uN3ob#lzsQm9&Clm&tQ7`^}5$\t\!ߤR~1XZȻ_+8<~aɪX*+ISZ'L@plJ&.>r 1>{~rXߊ{*L/[N."3 *!"E(򊪮 wu4[P7FtKζ1n |BD=E.:9!w+~W }*P}n%q;) ȤGVNy x|IwzJ^-KEh# Q)prHv`eA LnlKK3aЯx7bO)*cKzP;LR!-a@?+J5/ڠsŽav#Q/k'D_\/giLB!l?wFs2pbXW~ׇ| h(1aB"=o\`;&/⑏<Ȝ)9l böv)%"p6C m]f(ENdUɏ^ׁy)WpѤ^g&i~Q2b`NgFAV| s~#RuT=ꆻ;S 9<;3bjM?Ȅ36d^@`Y.VJe+r<+ (aN;,nLy))Z, _8 (|d8%S$8lV ^/ eK77ڳ4u=|󆠼k< y1_&JU5a͏87;-tᜥ>crq␚0,GMw4 *t.{IÃB{B^4Y١ !TcpZN &*wQ`:GX#`p6 s*G'=ds[3f ۱PfhfΆʅP 7}ׄqs)1YgY ;oI{+!WUJ?F?:lrdaN<rf ,Hl #Q|fa= |> fD _S3Uk#:BXtv1j'&v8'~ޫ3Uh7K2Xjq^m$O K~~>yv;t#S,56}zܫuVݜ&a B#eLfMM$/&5<5$b_*$%͈ 䢋[ 5rYl ~@),x1? Gwmɺf; gXΧю3#>V%-!o? iN$y h01$V=OgN&YK*[Zߪ`8(ۡ0+EոBCs`T_fD(J>23a̍OHRCϜ5R qEiYOc ^!xQ;hdh=ȇ?e=(L ~ZR5LγFݘ$7 HGGq}2˧ȵHv_4IV9=[OV^oB8YՅ \Gpׇ$iw?ˊ,-ď)3R?`1f~5mexQvvZV4vy,]uk n󂙋*x„-^+ (|֝EhSU`z !ײZ'5\ZTpHS{*+ ERC`ڼ/{lۿG,TԆf#1.Y5=jAT74ĚJ|=f G~D"Mg~V!WBC 8C#Ȣupb 1yIuUblD nsQ3N Va6do$nw}Gk`^BSo+VBQE 3m\j#Rl$сOV+rngT'/Y+ R-HcՒWcW/w^0zV߫^픎DUS@!Yz*2e'vmwe U{D0a%'>S]M} 75^gx%F.c=B7{3A;n5 '!"x^Nqv:2rSQ^Zu,dV+5,*"cpd3ic|J>i Dx)κRXOxS aH?J(hbjTQ|gH/tЗʤU jRŠ뚵@8si6aOm =?TЩ᠓+Cw[w<")N%NUN0Zyk] נ]/YFh\NH|ݠCbyUc73$"]7D;}P^m8vA_(8Ibilr 8BuT\ İ{RI+iGe]*t88ɋ^9B̴m"%#So)npE͢ZiDO ĬL^~KC"DĪ"{~NPA^KzAq~=ׇ/+#97ɹbց("_XBY?x<ـ='~\7s둦z>I, ?+\ @dt;T2]aL䮌 r7E"I꤂R#-'&7=9&mK^)CFuFit7lXU]ޜ#j7:of<IL] غR^ƜKJy5v:?Q"}vس #8aׄJ(x>t;EA+GVP蜱`8#ـv1<vv%D,YEn;2NԄ'SdKgTkb/8~ 'lYhJ"@ݜbƺYYYyH@9?͔('SBzꔗ'Igz yH`Ϯ-e71EVnU>uu jtpo7[0768 **${-7]̎xu3qhm4W+0M9_^ jȼA2jv1H6fj" x9?;~ioO/&:n/i~xem쑸dǏ Յ|7b>lfᷡ|VF•Ne֝o]y좴p~Iz-$}>=/6qapejDf *d0 zܾYKmP5JqPD8 z21b,-o$15 J[`ٿN 甐"ĒI$,AYS- D<&gfBmz1`Q[$gbT,ԯ }w'.ӼLQ9"0^^&t$v,>l,UhpD|<ȝQR}Kq$9g0^cM9O3̖u]T#)IAyqqJ\M~a'2֜ [ZGjE}p>/W[qL߽> ?*I*,VJV">+7RF{ۚt|JF{lRD]IMgGĝ;Qb:mNQɛٍF2dZJEVJwh,U-V ?QQZx݋H`oahĤHΛD=܆*hz\ax d߂!Y#ƿՖ;R\jWx}k?RnnѻN˛2Od{3^iT^∨/F U7)=&οhOodR[2BU󍱘 k"ûI;p7eHrH"r5(&%hYkE,-` OzV?3ňʷ[lx.sZVR3(OQ.­Q[1ุq4C.14ô_=Ny0 s ?EZ^XHww"9 Z'ͥVRtL_݋{si:~XܳYA 3K*YC!XuV~[/\@M4V10I[+ qӾoI1 S_CfX 0\TvKN}鸗y0"n͏ژ:58}ˌST]ofɂ~jy9QT9\TWB,f܇ nDZj,>ikYq%M})bۻӃ[iRJ٤M8_Lnf݅m LS =bw\$2PDߜvr@AO_p$UMM0"U ^xS3,48&V*Ǘ +[?J-M20%%,N"$Ňn(O>ujCW‚jaZSt@^}Nt(~Cgt.|A8YvRő̧ٙní/!VS#6}n,~V, Ljg3ԨF}րg!لl\9ʊ܆2h!SpzUŹ}Ix, A"dtcl&YqWpbw ͯ_.(&S$[3ŋt#|]S/;ԫNG~"VFrH.9z\>FEWy`C=XU扄1f$:Vg-+}[5LhYsB۾'.R,΅da$NAN5O2$ LaygSBUW_I8]AKȮ"/4UH9*QB0UNgb2))+֤/0[* c< 7>f6Gw~"AՎLw).R?!^uSZrFJ Rl;"F B! ;ʇjt⹒+~-L8P.6~GX2*]5sưb{~v_!r&N:# ~}E31{Js8m<fN];Rof.V4^>T`Jw+;??f f؅NX:!ȸ\xϠuDvĵX2 !X7yh08'\"+M-fӊ:bˆ|8YpS@=)Fvh̤*! cHxYhȧ⺰\f3CJ2"&y- a&*5;`:l&ђsa96L'6{mb"E"V M< Z&úU}|^{QC4 a}kQe4T) R;BE}K=RM.c[ BU2JNǐB ccN4˧[(Ԃ,NRШe3Qg789gĩꬒuN&cTC/N \I 6e {\cݜwBEq$Ze #Td9d^?U(8mkf׮wcU)9O{=r*^Zjgv0@/>.xrƝt?`wMnwhs7R`PJmIȩMO:=$. C&9ȍK i39S8Ue$/4.Bz tNTr odL?@2B$ŕ2dvoP <%a(Cg3|ߟ qD^xMg#Bfc֡zWah秮l.O n xqZ1=:v@<vDArRCJxZUARL"xeTI@ɾ@K7$ưHަ< ="R5kz`Fu(QUyߣ#>WXƈ!zh.ʟmsˆ? Iba\X@ӛm_\TƷ凁 gq\7eߊ "><rsv%LFf󏸤ign&BaQyi'ry >QH- 5}t)vcdy|s}2>=+a !T 9fm Kc #<'L ]P*^wm{m>>!4~|m&[:I WOp㕒6D#]pLsΧbN^6 6",KϽ.o#D s9UTnpYZh_I@9 09~!ZzSTNWnWɇqd<ҧa)]|fA,3"㛉݂7\TXϪpLnN f#yGoWo_2n]6FOTG! WO6w\^?-_5| mP ͢sͧYS!Yxմ통$ n{]PV4Z3$5RBQ|,W仍̚6b_)V]GxhWf#Iq~￷3^&olofJHkI`8ϭkDe.ڏ#Ffa[g??}zm~ؾnEMګ|['(lwFõ-8b&{ɒ;O-()f-?l T.MjW_$e/ak?kuT XtMG!<CN XD]FN $uoUi\6U=ꌚĴ=ĭ.s5ôbaY1FWهXTtWTJaҖ}?aa,}w~ے=On\ C- MݎUg#E|3Fk9}/+-]<>"=C*[YC @4g3_4-M@ɐ S;f}2}>TEdUg4-b[cMhK^8YZw$MD浾&܄D}BiɈ >q-xBRuYz'c;L{ݿ|PWXN,&Zc#d&6X6.m}|?`Z;SسRAO'i@SyB^=ΫdL?DJ, g:a%krgt KC sPǀC9z endstream endobj 209 0 obj << /Length1 1437 /Length2 6750 /Length3 0 /Length 7719 /Filter /FlateDecode >> stream xڍt4]׶wb=zA Ø^=!Z#zDK^I<>}kֺ콯\b7d!‚BҀ $$"($&2п\P T h Pza@X\ZXBZH I DzH*/=#E"(b.e %kKIIN\0;Ё pi}QW v!(A< C;P jЅB&H;Pho80;(IDC=6E 9@XP_d*CN!] _p -@8 ɇxA`p-ud@0esCQ0A`Yatu"(_#WjsN.\(o[ a>gNWݑ';C\ap? s= 1Z@7 tu0Oj!5(!1-,*($R@ah;X0Tza0YBBÈ0b4}UvH_b/11/Q=7 ƤƐ cJ R&^ GOv&߯#@Ʉ;W7)1{6%ڍ'4[VeZ1U=y32=dz\pUbN/b=#M?UՀ`$0D-wjnA;o7软8 m%-5/ڸ[fOP.%DN&2;!l#b8A:i~+]$ƋoB:X_[k;+ysd,r7(SlBtVV( |8d$N:ڲ~8͝iL1hF+I?=&QYY* i]vcVϔz((Dl;biQĵB՟1Y/{Ug*!A]t3+&s`t62 ̱"93:v6m) K-AN Jؙ0NΓW$d͇CV%5o :d#l"wB]H(Qw3[gwQCW__l@J+WߗY>hg ,DjŤB(=nkQYlE6dG륩 9dPb,-0{,/DlEuNyrn%d2=f(7AZpx՘.Tzg=\d7mؙSI< Cȱ2U˽l6~lgsE E3bJ8#D ع]^Niڍ/3w}}Tm `h( 2Ft%Sڋo Q{;!=Tw*k$ =\ )2A>ݳ!qT&mYD^z#{r/ U>mZv+*G2 >T$ypFu_j̩kJNs2or@jwyk%B%"n{^D ={7#ǂ'HҩJ2P6K{[E`)}}o MXC|9'|e9aר)l]H"빤#{`O, =Wl\|\l$ \ҫ {U n+RjǮTۭ|*g(Cwj/~of nC^'Ҡ d:n_XM8ygeČ;Lsg+tE-S V]!.`W־Jż{"ĥ <-Tcdŵ};?)-Qr^ٟ}'$1tZQ<_xmY~SKq 5>V7b`ui߷&[sf>n1Vg K%k_A"}xW|vtS9u9>b U tMOU0#ɨXZ+J(i9{=PΉ֫=cFD' gVQ7;ǒ.,Ǜm*xJP 4^,"h|n١|> :yIOQT# 1lRJ~L5jBd:%8,+'(=2UӚΖHj%iZ8,Eܿ9c1_*Fk|m>:|Tڈn&Q@ mlJU.+Z/e%U. ^l_)y %II:pq.yYǨlOzIbRqM]Prp//q${*>[6>)c$8(#7;5m4:(nM@p~p s- )c2Umkjf57%B*Q*~Y`N'^eͺ(ZpSS7iy%D۩1hb=UXO\qq#bˣ1WeE~FGs. vr~ qNCS j)u bʀ'-N\Fsݯ=Ucӵ73oOHFȭ<V+癃3Bz[ؽR0|1֑U4 -itїt`*W(^{fU/4k5[ϳrMDYmK&֦&/gIlh@dcy2ݒ 4׳ 22g,MΛe0|+&^4 2 懾qJu]6ލ\{S;"G<(-p~o K;ͥ1Hh"3~)աjqAߕGTӔ`9=V\kvY76#pc%hEl?zFַg۹ql^ ~~1gsq סzCSԖ'% /󰬃N/ 6Πwlߚ)rSDN?IwWg2iC7O p=޼5@N_뻦#hԾ |4\Xj$nrB, )laLyGLbb^'Uޟ#U jb|GBY[&S,AҚya$|.Doά7i^ \:~&3)Og q肵OK] i-4`tzAbCfĖI]|}6Q򚋤"yTi2rY5Q;E-Kh!?+u8RK@9QAOͼﰿO8:CXuIky߳𢙭h1~ζDun[t7=bp~ǁEH~m9c%w}WOg`;,@kZa+$xpK_R 0!gOͨ r)"Lfo@g֦>kWv%6k]tBp/, k= E)kģLwy&U%>ptKS `+%ّ~c#/Vs4ϓQy[ ͷ zD_->=\HU薼Rw VxhvmSͽ"ͺ;kxw=,l?uɌI}y.DZvwPWJo3Ű/N+ hwԋHԞN1-(@v@c49{kKWJЊp5pkLj9A0PB&.'D_ mLh;:jI)y㳦)v;,L!Lg9y2vtt<(6\! vh:؆g; fGZGHZ(U`h3mqK74b'1-*gy$/wUU)fG `!l,_ˁBP;:[bk o*_ B~*Ocض\r~ζ--/)+٠{.hŦ,A`ov䶝npeZh >wL74ZdJo)j1TԿansM"=S.gzh=2J\ct]ɮcZWNym 8^X3XjA-$eĜzfr,p)LeOVw3ICERhjV|UczC7|9ˋ5ԊQXP}qf`1au'l1_uIll^]r1bpL~R5y%M}v\C^^Fm &3jdL:sͼ7#~O#C7"=dɕg_Ifz"8# (zzF8ǬӘoC;$:8E'euL8֥PE:I{K8=XG%AmNY6^A5f ~ ѝ3o7; EZUh$缇NfޠX P0^ۥf܍ow5o\įBgzٻ|;kDң5q{h6p|E9W?28?>~R\d /܉:pvJH07!T*ѾpszHgDBn1ңksH~aǦ3mZ90rm_kYCn.IÇ>}O $N6]QK:,sxZeءaA5$`Vs<,UC?-hpnzXAYɟEtM}w8 ~8 =zkSqђ3iA/p|hr G'? nDXkz9}" 27 .qzXaKqȧ;k8l||QkA#.`uOdL?*tu>rz endstream endobj 211 0 obj << /Length1 2335 /Length2 16205 /Length3 0 /Length 17585 /Filter /FlateDecode >> stream xڌt܋ vcNضmۚضض45VF o>o{׬53koȈUL퍁v.tL9UU&F## =##3 t82u$DF.4Q#wA9{; `fd7@ G:Ñ;x:Y[W /u- gb}hbdP7x J^ nwwwz#[gz{'s~*Z@ tr~ 7=@? {3w#' `cis~Wq3:޽Td @GwqLL[!KLLm<-f6@, -_ąF3~y/-w|N@{2\k;{w;"3K;Si:0Y:Dy']l,#abہ/&o{4f8og#7 o"8&& hni;h'K1>av6j1")xӱYXl,v.vZQ4;iJٙ{@zPז\o[_|l-mIllom4z5z;{w{v3{'-eg0&qD N?} ` .?[QX л{dF w>&ȼS wddb |f.,3053y))0?Yޫ`jocc/(K)oQy/p,e7>E{-<,vxY _=?᰿h{d?mٽO ]8asxI2M߆W},w/.@S"2Ol_Ec{w~?޽1X8էT\^2 d~3wESwK^@`^5/.ٛXՇt>|s۟'H^ur}DNrJG\#z>mkoORxy6HP[)>j"ŧS(0T>tP.\.F-Z7l8gʅ J~? ?3,x2EhNSxr nڒ))ɦŰǫ]?\|T\>'6U31M#zx*ڬ%B^& SylV_\9CAT<ʼbPkr\u m$@Ҫޗ~}+u#: YhM<$\|zn ^c&$6bOZ=l[1>Om ;w0fa:;;a𙙥(S6Ef6N\c#+jsěNj eANcZbKfX *Іܓ"R$=Of|8ef].o}C.ՐزkQgHzTgNA "A+T2caV@jf~sױԵlVWU08HRb(Bh'@ h3,_UD]PL٦~v5_XqZ a~EPeuUۘ?ocJv ڲY(8Wń3PT/,Js_M Fd~[P#Xkd S vƏQbAZ'l&|vV̻]PK&GL1G,yRzّ}ܱ͖ *6NOJz x-))+'ܫ^UTYoWsx 3ӽ5‹1 !.KOW(Rk@? di>=mf+ -/{m%f`c")~wRwU)R"_F|F`DpcD0R<UxH)qR ,eS29D:J$cUkuNߐ2f6^Yfw?5[l[Q[;REYI]7o[Ǣ>f Eѭ8&E^MQeg52ÚL9:_݉w&;U&Ԉqk8[w$W@@GSn[C#IUI~|o.DJ7Dۼ[ L[P:Dl!QATi1U}W뙫.g8SxT#3$?Ė9*+aF9H{[fkFadMso kLFĂrly:|CW"sd=rj_,bߢ4Ż OMK2oiAk+=cCP1njJOr@먰3Sh=m/,VL743-ͱOy'^Wl$Q#һO=n78L@(ZZg33K5 WBo T˻Bp!rFyJ Snm!"Fx"+$Th{  hmv4*z LcAk^^d/a}:V-5nå"~"]+@90mҗ?ݛX~0Up[6L!, 뙛P&c٤fr-J87^i4ᒴ2%(*9+qv̜!\ %8| L܇*Ef $f$W2DASxrfـAv+ *NI a#$bvƈ.(-rCQ^]L[-O[LV/ݬu@/ }ZUW#6k+_&Ɖr=)FXoTOQKAMt(au5]a*<K& d$ L>/slK~ۼiDށ2aت ҜBg"AmKGtH8)@6wbNƷ,ECaBBn\a`-=M7 ȝzNp QaTNTL!o@H/B kn!#1/zRPfť>Z{Ȳ27ΕL2۽ƧK#+vp쩼?]O2sev[0E2IuCef3ݳE8^ 1Ϭ 0K}L: Թ3KTˤ#)Mo58a"X0G3vޟ1jgŦ{+es&T~I,ik0;\GW,eLڣ!syt^}K{uM#츍/"9_w.(L^5j:%_ƺ[' M#wqֹBnQ=-!=g6tDgY/S GiY&LrH&/LZfjymb.شjefUNM# %n70Owۣ&7]̿'D-]Rڤ& 1Pjɚaׇ3u@4+$zDޚ[zYoTɩأi;5n*7V4Yc,x(ۓ!AT nR$-! *?c?)> $KkyuW>cM[Y޶, 2ji8%Szm~ T; K* kزu fU8W5nF]lD5`T/lɇjcU>&#,m:Xa&Gރ棡M+dVRvL |Ta`Zs; NʚXb a<Lq FC;_$_SI0-4x(ng!Kyg(/?I‡9Q ⍦ `MhlTI -ٿ9+cƛAUZo3dxt|;Wc6@W B%-k({^(RYqZڒ^Ct?8q0eZ!"Qq8f2N՛ZQ~lTxm?_>^19UGcfcڷ_FPFhNI8L+jNڳـf4-&|`oU  Q5*I_[oG{{~W5f`WڱCԀ%Jh {r$xK~BU"DEʲ)5ѡ9J t0.W2pl|-l>p-WB+ )XyŽ]VWTp㱧4Bh#sN䒳"\KN>Nh?%~q_K;6~2llP<շ*:DКL.`Aږ9(9bF5q%ޝ5HAwLO܃wA!H p49p.g܇I*23Gh  ~{G(K|GNzE_r<]z, ,XUA`j#O=|mDH$Wc'gE X&i̯g_ho%!*w\hX Khe40,GcBDc^c! Y' 0Cn.ƞƄrvP+Nh)P[ ڔI9CO_lq* o?S38vd9ǻbm@7o g0]#dZBTy+ :sv.y5#L2~#-4Hۼmn1\e$Lǥ5jfg1a)ՖkUQSr OÏ.8%9'=G 7ì+8I`}z@:E B~)Lؑ(}Oo8e9gM|>9KLWDM6*+bSl4i 8Џu!حfaTP q ;09e- cECs9k6mAMy _%WN"hP̭8?E3:@!N33[?LR2 n9-j"h҂uDE(`}R:eX~h(m \MhQxugzfzGVz0˸'TN'^&KnN-ľ}ќ%o1'Aۑ@Gc㒽Ԓ 咪hTvUdr yNwd2h1nhq $RL-X[a`e#? 8@yA4pv|xGz-u6|WĪ4ȌN>ED$Ge܍sAHg!(q{Qn#W5u=O]gr *鄾wlidd{/oFM8#Ul&פ7@l tRʥ3F*v=F\["b jmHSƆE8v}:{:_OA0 Øt}YXR"㼙F„"ӷCqRHǵKGc#B+c2F}'"pGDݧE"I9pk66sj+ON& 9,eSB',|6h8ò$ ]Ǝ>wZM8E3z9 <^6*&w~Q ~75B]BDl7G+iR YVQ^VZ'0 'ޑ4\ lq*XTo6.9Bu꟦3*g-,;(4[aEi9Mu;>FN.㧭A.%n=e:~6<(Pݨp1]dSqc" $n@)` K1m|TݜQUqnH[C4ln"ya SԷŶui6l^RI8DKRI,8;**Zl5]\(Ny(UMw̙G?2Lv_w2ŏ]Y/cQRFe,^ɊZ$I~yN(i)@[-EՏ942cTAfI_ñ13uRz߶* 2?*>/K}sMP5̫uMǨSO5jԫ/ghPU~-dt(zK+ֱ\N#H.kwLe& 9np aB`ma_^G &AuhӾ{SZ?W\|@7Y/f-mW2{l_I^ з~d~#(K|ndtB z_-oNe) X9w-Pb 4)Kv4ye_Y1o]NG&ùjƧ_,Po:w@2{T`H>3dZ(V/ =](st11 ,՟ܣu[P>3C5kC4V& vXUa|JmyO2O ϖl9X1.LAP o ұ'˜"^u4ҡ+<+ؘ8!2EIn G>BW(1㥋K g2/=. Y|ne&%`BtiJ5껏7L|:@]oE-w4 ak:ԐNO_C?(r@&%ޙQ {}j1ci@c֌i\Z[}oňi0/{xp ?#.߬'n$'\1uԌ .aHʈe $ v=#$kLԉiaigz -6r?hN}$?Q'FRUǮXu¸K^1)|G r5eCpüh؞y_.2oϤK- * Ji9/ׯ}&p3t~:HL fY;+fy'J K̸;NȁC!K"=+Xo@3}p}3^}_n ]ɈhSIadKXwKfQyd+Y'$2% Yat.$bbgIȻB0[A1ӎ&U*z?;;s{i3TghRr 0*d{U>P9!1"xfĿiމku-(xvHvqsO>|E8-f=&)A$@T{T'B.: #USsXH:}zI#{qRF4jWYB/.<+ov?LZ!Cr^ yi/ ^rYQG_k lZprL ]v;e AT758wY%јK(j?d֒9%'@4uwaR]l!GKAm a_\R{ED~ zlNZ#(IS jMk㨤%a6i\RA5rOy[%xXFwJo*ʢ%,vV$9sVDA޼\j_\RFn|$2gZ[|F˗vk:'T>Ȅ"t,r2+r&EXUZ 9I${1e1+/`|҇"哚R]y(DD Ylx(JG'(|Ckj ]OVDSϢ19rrd\6X qc#!9,xbuYʘ!Ȟ; pΔk@_ a<8f|Bb# a41OD|\F/h{mBT\j+p~QٟCklB([]ųjcI02VE :qʚ`2ș]gݽQT!PNؙlȱOkŠg 93`URŲOUE:66PLv5 ;x"9jIJUt`Tdh%) fTZ|vw/WtM &̶ـjF|"_pS9Zkc*`(#:XR ղQǡ pY=E9"}, Q}X:y&`Wuӯ ipzO([HBp\K˛sbĨZݕچDx8Vah@/]p޾M(9Ϩ扨QI` n@T>k@aZSp tYrv~QINSt -ܻ!$U _8|\,)L>ʡykBuhv("ڮe@k=s(2W\)Zr Kp9y"f\2 D 6ߎ(2hA#N\>|o1YpM!B vڽ n ݧǾQhCm"0#KRY֠ZF4[r#'}XZuuS"~ 9wB9'5Gp^Evi|ɞso,DE""h+y(YG8Gqe\6Ѣ ^S 1=y٧ݏ{mӥ&\}s9BP Z :bUd^H>oG?h>6 da7>%xØ:L`I9,X?(F 7ɬHl8[,.e|?2A9=O$UD!3w()t"ޅmouj<\ ~2ԮX)JE:,P֏* |R.:Z~6l0D^-Rw'xh$dTD b|d/h\ޗ$o@AsۥIe8'*D!Ԟ %☗)K4<4Pd1>k)<2f|_fTGgIqlz=P%IaB瓥*3ml'"qLLJoOgF}+,_6V#FHlj,ڼb /̸lQ8Eh5>W,cz8fe *^,㩆NZ#膼ȾO5Y(ׁJuJjT$_盏I1}*zVD5Θ;VR0\F`8wuZ]'mu3 R@p-̴qJ0x9F2+ {-n!VWzw% vk"bH}~8r ଆPqCʒk VڕXoɚ4歟AV]~GD#_<}=x?5[ZF]:)/} k{5ʷily+G^T4~n8}7x\$lG|d<ǯq*@5qqpB -@q9kӲ(vf-W4kܒO!3 q/E6__j옂ˏx̌<КuPDQ1dUY5=%s0Nҕn8w? <]ۮ3}'䌦G*b&ۻZ!DsH~.֏H{Utɔu77L5)FRPJ̰ S4RsA !Z Q YdR|כNya_dķ3KݟĺKeGFQBam<5 Yx*>u*Q!$ ,0؅V0%m/q2:/ۄd':3BgGj 23 C g76k/`!ϡ* wJZ!j J4k,_9[#KC$VgH Yn`<*2Tp j SCя.Q!mDONs[6-Gi栟 .i[ࣹ<0aB5 9%[ΨuE咱7i/ |Ü t < ƅFw'jjS`3[=Zh# ߔ  c&P&ej1[i=\nhhBġF(Mza%1 +ݠ6G0z}<9pI.47<=.>7y= l/KBdu*=LFie aԨ_8_smj~ ݣW.:{Lsɿd@v R*BFj|y$ȂFT#l0>7JH.vmd LU^kf8s54oN[#S)᯳ZUgo L"⾗Ӛ,DQl) O@O ^iCAC ED9L +.ͦhP}[Y'SCg 48%]Hi7`)MA$Ԍ +fr=?RoH'fxZ23.mT?yXwDBe'/~Gdj5zA)ǍWp7D^|tl!R':O:v,R&4ieE:&|3>8Eʟ_}M7):axgjsH9l9Н>an|^o&k z‚n콍3K/zqv/q4Vz`394B{G[p L|W$o'.)Xx}bD"hOZi(u}.IW_[bƣvC{Dy>s#J>w6hW2|:V g'3UגT&IN>MxJB3{%z:5-'[T LơYoxkH-̑LEe|վR7+sMx W޸~uZY<4+C`?s"+DatGv7eWtPt#DqedXY IiMsC4⳶|ЭY1?k;V||G4&6ӫ ѵjN/Pa6_ݍZ"+\91I/n6ρ.YL>݆qJ}k^ M@F0LnFgnu讒Gͤ YtS]IIpH5wMT 1&uWǣe\ xtwGmMd)&q2nt4F@V ; F"1Ya(r #'-0K3J:t-NOBVh Ho cb:$.6)m O!d_3 QBo8xY h|r2]ݺ/jF~5 $ h' %/ tYu -npVчt!on*vHtx/ [I˶06όlPr4qNC(k+yBG1(u1{ d&>e#%Bqղ8 E9deI :uQ%e,>;J5Bó/¶;ZhttЧ Fkyps^&1hԲN͆v ]?oJq2ļ 3`EK ΁\{[ ~c rIIX",]lz)|v íoȁaW&bq^ӾSs[ntlqGݾV;Efx+1 6yFWcd T x`?\%d[]|82th:ZxsPd^eݼI[MYFBTδ[gUƪ/PYr)5KSlᙂD9LKܼ.,oU<언ދ0c~,Y!ϴUuR!`t41׽6Gef"%*<3m41Zͺ0G)]>T#d}XŞc]%B{4%RAAo!/!NkCƂ)v_|e&`sg٪ꮁqoɘw?54R|/RzɠA-fXe qR'}Jeb{KɑM4^;Aaf+)8rd>{ UW;>ˑ1DȀlop9tpu;DkGxbnA* ͽIiO ^r #)rPCiB Bez*׎8eBHvolA8Cj =k7@o ㍠t z6<4wnox]2v_8ZS&aBQմ,Y@;ku0 Bbe_BcB7D;㶊!}:l爈Qы]u8ѳ~6H#T5ԩ+T栿WV~NA *;1!r1r6p ~>"/si!ПMZԠ;Ruܙ)uUt`ÐεCXѺ/;d'&<_sKڪАFgKl<%pT-{19tڠިqoרm.ta̚s{D4DQZ^W?]12x>NKADb]lBC 'uyk髛ze4p5KH7F E֟}kN.`kCgE'?1go{WҸC8'>h1)%τ %^R=M*60) rz ?lA:ABjN6v bEUyS %tHT'J (lZ2u[O N89 RdJP4߂xXxVHgp΍M7T endstream endobj 213 0 obj << /Length1 1743 /Length2 4706 /Length3 0 /Length 5773 /Filter /FlateDecode >> stream xڍt 8m>J Qg03ɞ-[Y 3E%kEEdJ5E!BdɾﲔoTou}5539y9ϹrUD Fq$(TP14P(* $?vM b8*4D"Hh80q]B1(T" "\(@GDXNؒ(y "ဒ#E"pdvdD"x$Mrr$ B&EDQ  H H,rKKCYxnр[@%H,!?88 $?~#[etMj:h^  J8%cШ+X6~C_/ B,Ҟz)BSvpHͭ>uhS3aj}Ι':8֍@xNm'RU5 Jl_|p/ .1eV>r Vz$+k"j}mr62._#*hxV/ih^PHwB~ޠy:voymq>m𝑕^T'$KE_ZW)O MHgNQZk PǏR!f瞘[tmݖc ucSo;MwV%K#߹.gp@wy\7/P:xnpىIdOk7r^x Į("մMŅo4UsМY;^xWt;i4ig;OGl=2N$[u<>m{b lbYY+&Xޡϯ$BMzBXyLw#2S2fgxu9tdDɷƄq#=~.ޜ9GτnjG~I/FÑ w,A}{Z:iudǟdݜ׷5ӘtAl?Ws^_KV^T[ZXF*m?/̧, *̨}sI;{`UX=-©?۾8(@[D_ٰ. ~8A<Řv^ 3c㺍eew"Qa6M#Aק7DjB/Vc=E*Rg%oة^߁4oy8Xv02U2f7c[eD,sin+;jt.A9{MTǺJCi??D2h.ͳ|!4\51UzO{7W6_>aB{Sj ofklذO4X9K4zUvv!c ƶ69ڹ+%Q[9Zq\t>/9[GoXj흦1gږ'\2hWsQ֟fu;7׆5s j;G KǍP)f h*45(G(R]a 䴩S1ʼXr[.vl1݁o>i헂C&=9 TC}\|4u.4L hCXi$4.<_U(_(RV͉Ƅ|ΰ]eoz[jK _,b{7z ?\o5c2c%ERy[SVUz3`!D$/6 4 EwA>yjzЩ;qOoV:e&F_esdqd1Zt1&O9Ge4/Jr\?F7Qn[Xa'vV<2?!T.0̔qQKoq96|d.$QS@^_mzٗ\eicvSDjG^nwm◔vUs)Un_lňjT]S 7R%e67HK5S䲼gJPqߝCOw\>j68/eҺ69:>XSX &/ T}jL!8x`KBNO w. >WOy1.xڶ5_֬0MX@1.wcAv\^&絞p~&gwA1ٲfKT'W_p;9˜DX0#RV+_ؼl?NJ}@;2H[g |aii|˷'ERom9Vak<%=1#X? D/aߵ>wh u􋖯 Yk5 u^X6>c"M=`R!ǀ:85"qu΂1$l5li0ågY?#ccR-©ז"_>cc5 Pj ̪ ,k<&~jKC^qo2 ѻCm ܸD\8f\Z/rܸWf]m#{"ױ(d wٌؑ9+8:a]c@~9\>ڦa)P~pkHxP\_c {ڗ L%n#>;4*{i4sX\{+lGkڊx|Kj *Z.ZsO!wԈht^ԒZ'U =,>W. kZS΢qr*#=zX6eh KG壳Nxp sμPȞ^ |UgAΞ5|%Cbo4m]\xXIPәݪY}{!&'f>=аYE&VڻC4O^[pȖ-=K+pkׂΔ[~~Qtt_'ҞM6"๕+B ͉NdDV\zQ7R]X ~, chIIꁞ׊p I)9tUPURzIJ:O(h.z?{匜 uҼ[/ޟC'yy'/wW|o݃ jkN8Ӿ{%19MԾji\/Лx̲*co27Fbۋ͸jxkgcP1~``ad%p.x1K$|)g&LmhMj,9q4@dEp>p5aӵzwq;)Ʈ@nAՈATcx"T6o.l, [k-hEucǗʻLӴ-94X+0#ѫdcH◝=W*wMcl[~I{/e UGcd82^@msNͯQGS~^7p}&߄H;U8y+O[36U\Ȑ OM|4:z2^; :3.Nup;f頠bgr)Z;4WB>C?Pz endstream endobj 215 0 obj << /Length1 1595 /Length2 3445 /Length3 0 /Length 4453 /Filter /FlateDecode >> stream xڍT 8׷,ɮef0})dYiY.J* Pe([?[]]s]3;wιϹVifb@s*P&6p:!p ? NR @4φJ,$ p@H"Q,.`B PJXeOu=0"4"Ml H*b$%P2 0~z0X``:LWҎ*Dp -k h23u0Hawh@ RPiTp:d dUl:Wk`4K%)DqO$:# )5"DB4@s# 5=:FcDZ4Д(8* Rti {0RПOkM~#?@FVԂrA`@8 G:*scX& 7^@0 I\rkFvPsģ?evi GۆKU92eff>ffL5kK[y f_N+E͊Rاq}UI>du[xayi{dţ'/&:reyqNqn%EǀA)VmE*\KbL^R%V4o).E2;-TK.DcJ)eCo&F/|}'R_Z4u-~޵Nn#*ȍ/.зR>#{T̻tֱj9ooΖPFgǽK{To{Izv$ky+c&3D)؄{̢4DzUR7/P 6?ﲾ@ YTƘKH o]VrWƃ^EοpdgoV8=R7\> puix6ö{%Ϥ%1($m9m|߳܌ءYV?Mp?Xp|dK;doZ9[mKM]5Y*5 Wu쥛y7N)&$=]$wid~[: mzEc 3zbOքAe;WVA1{wձߺEiCC,799"X%gд[pp+P,ߚNZvGl,*!Z7 ~q٠OC=Eo'$yƢw1n-% bfTO#X ]R|߳a6D1^s0I:EX (6/-|@T s~X\r݈ݧ9Em^yښ=;7NיiAE=m6P6˿eJy\KVr&ۡeڌYAf5reTWԸ\<{Ŧz0Ih"ўhg_!\݊_*p)F9֥gh9q#YH rivA>.M0^zL pih[@EeYځR% wB'ca9.OR4 ݋n5oLJsy>2r"gk.Ȥo.0L_GBS^-wb7jY3qBRF?Wۗny(ȓ00ȁ44! 7P?|)Zn ɺJ%/X7%+fnHل{%,dh>v{ԤdMƒC5=6D 5,"h:GQ'xhOU.]Cjgl;RuV{y.^)rRT ӓƑ2Xv Br)->ecfwL>\Bq}V UNJKPŀ̞3犄' 6"Ѿ43\6ZdŌ*p%^}=K%D0*,"ZR钹gGڃppz.0xp%»^zڎ9vV6v+[`QϘoY֎%R#u89ֿpK9swц$*Vut 9CsSZWNnˍj=ٯE!o8 9OFDoIc#^t7WMstvسKgf/{e}+Qm{ {ɲd>3nz}3ѴWVQ7& q- yF鬑sO˭[y,{t΂npƜ2z+OսPc{rWozTjttبn*Nťڿ4ʊ J٨R.h,})[v]"Z3O^+]S]HqW*XX2%#vqj47VWy+%7[i k~:EɶpʹuhLw옷%{{cVl5&8ڻp[`ٗ:JYrgfXS1/3fן:?_費Uu .JpܵNq <۰tjl+EwEb6n [Usp`8+9ZHv[۾PUmTI=rRmxIχF|A@)Ͼ+PTN*E\ @xዳ9Vs~Ѣ$'Zk8ѮaǕTUirkc:Hx}z獜&+gϙz8ᯌ9^]Jy!&' fqLG>[;ۇqB٥b#cd{.Zl}f;~PyQ KSN` XeX):ރn7CM9 {Gk r)3/N FdEL:S3 Uߥ8ntd LUpky ٞe^| KWYvu*LzhwWcV?YkyI7iĥlw<$C [amt7YŤ|M1DZSu⑱_ #l跣 W*I*z9,TI|#*0SB]=,V0b+s%xz'(9UkNp@LAVTW2NA~(4bKb˥v+{ib+MqgKD-w9v͕FUL]_΢rk?H ,Kh3Ao6za%W~JR/ endstream endobj 228 0 obj << /Producer (pdfTeX-1.40.20) /Author()/Title()/Subject()/Creator(LaTeX with hyperref)/Keywords() /CreationDate (D:20200114123150Z) /ModDate (D:20200114123150Z) /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.20 (TeX Live 2019) kpathsea version 6.3.1) >> endobj 153 0 obj << /Type /ObjStm /N 99 /First 886 /Length 3647 /Filter /FlateDecode >> stream x[[o~ׯc}"o@P m&Ӹ1׶Neɕ4 ]qw%E lQ\p. gHiŕ'p͉Z.=њpW&R˜DIF'*b${b,FĞX| 'Nb1b5B뉷(84 Kh!<\XhET1o^x,Hf(g€0Ls8ɸq-\qPLr8Z)LC`D)@-o98D[$`2Kb<#8xc\@( tL' fhs('d .wAG8,8[x1~ /n Yz9R e@70w@7hPXx:u0L8^l.@8@Q@HP -%F@)$6^!)pRC/0QcGJ ZpH q W\#``#⡐@1JS0z]M9 (x=|[*{to2 r|ӣon:(gabXN>31=`1H㏁>9am!}0Xd|7b pFĐF8acBpqBTi.YqBH.tXxdp\@IiNjI+48!]NȃÙpzg++F>c&[bA7 r#:^"5!nF,;7#BӷLcEhhWquQ9b@32`0}3ے>Tki<]/F}(THv.HGZi@q݇yA٣/2hQ1>XάvXHs ^mco< q0{ŔHߣ/b~= ڧb8 0}TɯgJ!se IO kak>Ce (G>Fb?O:S0fYSGA+?'b@j'P; -r Е I VJ@ʮS0E hIXx"%a97~rf%d+0cF8&ElMHsN!y1 I2T҅nh^2VDG54q[Vf8.huNxX_i <7~ sw_G89xͪ m2_#B+:dڰz&ԻV/PˋvSZT/_Xpf,^ (aO9T/kxH6X5:+5a}a3d)²%,Y3oTEc5 nW$'Ì0!px[S{ұТՍB0BⒶ_ li'ze`c永ua&~ Cp+ xcAµ(2uocY ;uՂ7\e'Pru9(HB` 0V÷a fGN!aF3*[B99EZ,b")squX@.Dy5m4T/½P짖vu/gv>4kˣ; GՌ<$fbB-x2W{t]>/Wp 2{ OWyy+~ݣi“|&?7tHoN'N`\_2ở^ENXnh_|%J=z@C,}Kт~:l?Er NGKzKoQy9) t8?|8Cg2/ gNm0~ۣ=ͪR !%Faɗ#|DOʿ8ځEGplu fl =r=-/E0_O>}[ˊЇB;uܢWe( fh:˭}s4߭TQiW1ߚQ 8 wX q_C-,ER~n"Aw'OO''֨5*!& `e  #<C0y +U'W放|`V/h1 袄.އi1%qd4*j/+F475- ]r6 !Zw7@՗Tvt7 2ŇQUu+܍/@`2-צJӧ??;Ŵpr*W!+u4P7ڮ+4jeZ>(7-AH}釆BՍ֍ V\usŷ*Q'/^=n[Q8 VOn[Wr }֙y->6ߪݳ'1WT0\pج_ f!15֡֨WwMWԪ֧U nᙡQx6|5>g$n{CCS<>.[tt緗5t!?Hl3C0Ub%>/K#k>l "e 1XG|:>,ZO ^m|䣺|t^q6Kp5z*Y/Y8u8ggUrU\qVKp5r2Y-Y8u8ggQ,,rEXqKp5|0;l@@"(F* bx3DVdm¸&wf'Vq1`wn'0 q4*9]G=CoA,}{pQ=ؤ~d o1VW~lC. 36lkO]iVX0 XK/JeQvhIi֬K$ME=]wպLjN%dzb^&W \^RbQʣEIʊY˽x0^R&? W糿 g endstream endobj 229 0 obj << /Type /XRef /Index [0 230] /Size 230 /W [1 3 1] /Root 227 0 R /Info 228 0 R /ID [<35E66B34B590C0BE9C11EEAD3663AFA3> <35E66B34B590C0BE9C11EEAD3663AFA3>] /Length 553 /Filter /FlateDecode >> stream xWQ>.$/*\݋%`fjcCXgw󞈈%DFoGV*AԶQ~Fm UujPlP{:Zcj4#<Ƣ4xiG jl-%5)8أ:ڰ %IЎeJ-bOX&l8e@v.,S= L9Ѓe@ÞX]l3's K` 0 8S`\Wuṕ[3k#0f hx!0oZ5p2CbWEދ#)K94N36>'s^cJXU3>"j2cK&U1ޖ(>c5"*F SsFeȟjXY FԞ򩺃-8RIQWZwe["煔)XQ~@6D6D64O2~c5Yj4sXނxwV?;&4U-[q"9T h|C}% DJ],z endstream endobj startxref 149768 %%EOF xts/inst/doc/xts.pdf0000644000176200001440000060552613607332267014152 0ustar liggesusers%PDF-1.5 % 89 0 obj << /Length 2128 /Filter /FlateDecode >> stream xYK6W贡BoyN*JR5h3Zqt7$%rF=̈A4Ͼ'~ywJDŤ0zv}31 ÔMi.c K}kݦ5m怷M;{wτ`Ir 1E uw>Ysz7W*^a]\aޏq/ÅpnbfւTTek\$ ^6\KPQ)mP3^J-UXnk7WI=tE f<^\}f晷 q)1/=XCG<ŋ%\u)^2 VZASxRC|2oB ^pxwRYJI5K`Ÿ`x @cKU!R |1[N?ٗ'OפqZEzj+tRp޻炙_|+l6L"3*Wh3Q~zSS D>Μ v_̩jH+*WfQ"dVɛO,݄"gi9ꢾCJ^JJA > X]&G(]nõ(Mj!\tfQ{Vifwרڞ) ]וE]w$ fҹ! 8s_fYzZ@RF`"L6q@t6ͨ7a .&Xul933xBݻLcY^ڐjGW-=&wbL)BTCrFTιte tGMwmݳ T3$B=2AV:j>bl0C~#%FSZzdN Pٳ̯.k S'3;"Sb7n" L<]A)c揱<*Qj8eԓJw#j+s :?T5aV* KA&勈rJ閉J}Mj?t@SBnQP+~| 0ؼ8ݱƁ¿cnb:/mD<^{wѽYڗFN$sS$ľ#&k;8Ve18$Fg+dž`)i@vPާpHj^AUDcM7sLV[vʀ ǁC'ˢ=Bq9YcKշh]zϤ̵U`H6Hc450vw)^,<ǍSj›5QSBoބۦk8fFmIJ:tvNPc@[-)WGaYaӕ֘lϏx1JC }d*Cw&EQ9)Iv4Աrjw)m. &uxqmy88S^zQW.i]ƴ|s$cL˔=mOJ FAH(xՏ0V-5 de 8֯L\w=-vѿII=hbz*ㆡU # _M;0lmT |@CgThu"U=, AKHh8ЉئHs +B2n ~ -j)16Y Z"9FoCنaqW<1:.if bqLWfYj-bjѾp![ ;|qnI?#A4Mb[hC \HK6B0{dU "msy@t-3ke fIu"c12W'849*[kmnyt6qSj\34b,%u' .DE$*qeC4Aq*2G4눂<)TsOu_dA мp;|}PY*M'aCH3sËQy67=\SFwxws4! nJ͛&P$E78eZ2>Ii:er>ꤖ3e "9Rޟo24T endstream endobj 106 0 obj << /Length 3902 /Filter /FlateDecode >> stream xڝZIW R$N9UƝbS,ӣ)jC@a{xކ.7~ͻʻ*${|MqrgE}:_{I83`Gn~FvOQopglkgW&d6nLcp%S GG#H>˃!'+^{ǻc&6ae a ;>0϶",cv\Z+�iKWV1X'q{C>[Цi 7&p uN̿g#0RղL>x owƔqLa-U1Iz=PB/w`uaz7c+Rysok$-y8c'M,gvO'C,IϖYg⸱ۦ5Ir4X8/Ar7(R:IE&|Ig~c{ċ'A^xWW@ǀG Ma)&k@a7H1W6n{^7I8ށ4; ,;'^IAh{o4I*gM=`c-'W45s\M3.|3>C“f4{hx"TzL7!͇nE(HU:PjUwA7p5U6tGV?yjg:1uR'@g<\$t+4G ^p)KV95FO]hR ]GPN/2?~M kgHG`{'"BSVzimO,@*o\ѫTBE`뮕=Ƀx:ڭtzTI[a!Y& !;9"B&Uflh7ҩՖVerG=~l{t33;%Əy@8L@{/aäJVZy w pq/U`h'ey,@VnݢG2'FJ$(-sN+\ E^9/\GW]`Ӓ3ct@dcgZSޱNC7YmUzءciXL) 佪-ZZbna"A8Tc jC$e޹ *b%(h`} A UJ0ed{ p4ot^8Ċ/V_TYa\*EU6_IFI%MwƤoaa faK#ziO^LhÁy^o4|3LmcUsK4 Cud% ~l3B`YZ[ Q I+V}6!FppZaZ)ҥ&^g4NL 5@a3%_3d39b#6{6֎ H~k<-ꍰid.\{2oӱFq]P\X]+7<\o78,uupĂN~o2m'N 3 عsG/>0%EM~p]Q0[癙0-7x`FWZ 'y>MmĔ*NDG`֨9؝Wyg,xQ8̅EŬ* K[x/IdJf@j$,6^hDžNtLv#0GjD) xb202%P)pP:\UB ә0Mnپ,VR gB41S㰅"ZvX~07bUl g_38],1f_]: e-M؃:]nuxIe?X@}]Ѳ |8y=|GEǽ}Rj,󚊟lu/3>iw`iobn&`xh%bfyB dA\T:e kj.4~ȅ@kEW7<Ӡpa8jb5KĿ1}RYp#$vO!l Gq$)G rrofj ƫE֞+ћRMu[-=HF4,)e;LjFjlI%fCU KV5 }y) ۇ.W8E;ˡn}L2L3=zR[ƥԟRo<g^Z?*6רWd 96WA@[1rlMH[AO"b{Z"+x]aƐKKIyaY>=/empC,4yboul@>ѾIB`Qef8 ~5nY4O!;[g{3FmЅi*P h_F& iu." q^ia&,# endstream endobj 112 0 obj << /Length 456 /Filter /FlateDecode >> stream xڍSMs0W3EpLҙ=(Xvhdl'zŝz~{(qJ|ީvwheAU#R gk^|ͺB^Nx=L&D"xάsuC5_< QnF.vSrhji@ ,ޠndծ~S^*7Ϩ|fD4"ZM+M bӞ5',CH8cP5Qu4ht#s ו#\Gٸq^{?qQ?5AJt{(~eBnD__! $7UVK]L> stream xڕZK۸ﯘRUܛM9lRT%U8gF$E3vǧ)q#F?ny)n]!_1e 7sߙ],>][,]Gw8t>fss8|O 7MTiK&Eٷ`pܯOw?Ϛ[.]3;蕺rtu\=?.qs}j[xt&|uɟ1E47H"&!? [g_VJ| o)wk-#}t(υP jc,2LӼ"w.*08/QAe:j$or"5ؙu^?i=c u@WYp&UClu^-Giw-Kp{QŖxn͚\t*$u"[є>BGCP}!v31%IOh3_ [ (zi8h '=v0<1%#1Q^dQ#lxwWc&Ή W(Q?;0F`,5Vm)yWrP#lO26-ަ\1Wt5s+O C&rvI*z4F%USLY ӫWG#}F.%-;!!`C^iM!1I-ۉ4IYqygހYXo_s^xi$ YÒSI( ?{W䕩olqNg%)KȘ?TQW =*IRk ר|C^vd9trIR:kjcr -v)`d/Gtlva;=!ؙTC "8s˟aw/FAԱQLÛ"ٗRC32{uz =%ݬynrlM^ ֭5CBS)VFW "0ZhHO`j+#^cILqؑF?ޠ\ݿ4e |=z.t;Jf?;|3lHRf)$"J8^q4kKVXZ`Su^rILM2s~pKu~ o^tTmxx#xT4zI:펪T?jPP܍><gU"Mr6o>z%}W$'= $i!.Ǚ9Zd/-&K倲%cPoaWL~YXy:;ߍеz3.q 7!j?7*ڋIX\Ws5SE;Ɲ|BϿ񪭏Am"m9+I.; RQ.O|0Z6r.o}hc\R?#>\}"C,d ^A9;B(F5HEP,&<N(hKI=݉Z93i|X@p y`;>WOk"\!sR6qeNPILasOgp;GͼI|[ā] L̙5kja8^a 4k 0Ӛ)+3s@H3Λowŋ;t> stream xmSMS0 Ws#0.6 m0I#JCdEevLZ] VkϪG̻ qj_~go63` X0yL{һ0=`h,+@#u'DBg_ f՟˵ :x "nc>e.^X::pϱ9+%JGxRYXj(4x+Zט$2`v ֤1NZ!u _.a,tǨO'i |ӷwդHJbKj0oh4Qu`rzjc$:Jl4Yu܊ၪ!?0gK70휑'\' (>xᬙ h̏A )}˹V endstream endobj 128 0 obj << /Length 2102 /Filter /FlateDecode >> stream xYYs6~ϯd:S"cڤiIiݗҔdD㸿{<ھ&cvۅ-.8 +fqYhkU4ɔ|5Pk?/uS/]/? )2k[귰f&SIݼW%LV/ KPEjR\&jVyo`5v\&1ڥ|-(5ά}x6h]:Qxj\F=utbLuOl: kps:R?hg}J^nn/MY);:Y%<$2L"C0`T'{ʂ7hf [OɨN#eg^8Sa#}$@OR,A2ln jHS\LTy%o]8bASbLZ59y<'Si~H!!<ǜ%Ka -W RGSyκA*^<~jaC  Æly{ aA%8"Q2FL>bRݪ"Qv u_<{&̒ YQL.^B &$jec)GrQUAj!\ɦ@-7[W]Hcl"vv'4"BQS:yK0NF{R:Y۩?Pߩ$pJ6WqΤ庶' fp0jWswꚪM1No/upJWBOoPUsIA/tiiOwOe% ʷ,bȬёX8K{fЧ9uc/E]J? 4oCi<䂒u7RTgQDC \(W}%uU \}boL5X`"()˿y> cwQ՗w{ڶ[m.\8)졽X[Y1 V*7GA |ϧqh3MlcGeQQjHcӜ; rUUW*^N' l7tevDeϺp*hITa_ۏ3iŕq[X-E+ou3m7ށ"cNΈ#KEVQWB˯2Jc}w92I 0sQ"ϝ\]d?-sdt4ݦ\CI+]u;g ZOe{1w:wOy Pܝ;&f߫K*Tsw`u>N}˵`᥃Oy!ӥ^@) S46 C@#<-w #]dxS )}{%Id|+DZ,Skޥ ;ͰT#6_#^C)( Q0c@4c˻^pѺO෪$RX~88O[͈T{,@6\?Ð9Wן#v|_jG{G wDW*mۑl2+HtN(/K r E拹~XJ&e]q㩱\Aw֝shD$3ZhԢuoGU %&itM,Sȏ`W} endstream endobj 136 0 obj << /Length 1898 /Filter /FlateDecode >> stream xڭYmo6_"#Xtu(bmѩdԲd~ǻDJst$t/{'Y2)Dt2[L"KIj3̪il>@;-qVFbJF'$W,~gDYW N1+#|(|3h6}Y>ƒp-^Leҽw7=yY^ B?~$_ eP3Ї2ș ` h2 ;b 43(e`v(3H4D_ u"R G;P)_8G۸E'Q5fbGZ}ga2?[g νKeDWDMl-WX)N; ˫6o~{f$Tm^@:!p_ԾRxS2Q =&H%H- nlXceS|,'9.w$2Sj ciU2\AǹS;;}[GyZhϢ ږ 8/ endstream endobj 143 0 obj << /Length 2961 /Filter /FlateDecode >> stream xZKW,X4/!@Ƴ<{XFG<Ǣ4cW?Hl  buuuWN6YOߟer?֓y:/u9]Miͤ,TbrI*O" ht^+`C4o UZSE,-b;m᷇.SiBe겶9E|W߃G"-Ku5_o@x-YKȥ_ ~;lʴ՜ 99rSo9^vcL/橧Z9&3擙Rw]tz2Err%r鎉LynT$ldmEo,>ѿ原g=~ɻ rXii+g:^|ΌWUI'ڏW3]JeJ^IPD~%i;[qCn_1.{h&͚pO{ y^9#(g:5P`W[r#qbYiGl_ UZtHnN k8BNwv1@*xġքCg !k{Ab4f!JSO֕6W*BX hQ |Jy1?<ӳ~Vao{{q{yDC GYrDpDP'\$6pe 2Rx@5ppvYW3x-d7@&mp N3zvt=2rrP!!6,# bؔ*;󧉲iZJ+x&&E!(])Cs{ܼ*/"P ;/ `>"1UqJ9 !V@%r,pO=˷P"_ eKfec}v//J(5YeR$,15GZb dIܛRDec.%$h*jPUmAfaayE<Ֆ6j(R2MË =?.D> Y&?HZ ɂg[ G?!.}"~fE&ҡO0@y3Ot$֥q*qX ܏:/*#U.DDnh:a=@=KT` t] M?V 0x#l+f'_/v$u aBU`-,0;iV  w] Yz!x6 gžʍ՚2L~ePE_ w:ĥ 'H.s:ٜT!hȚ[Y go)'d,+d C.q%΍X 26,yuE?nS$$E`OH]o HF0K@0^o{SOܯNv(׼H!NtUt@ yB5w%iV:W%v_ɕe4CX=C 鲚CC7{SS @&&"r͜$b4 ~q0Hgyƞ#Ũ 7%maeK i?kkllev\7.9|97lוqsW9ň2/[_ dEX@U[zy"J@IFRZ .촄+HFjUNkȪb-|X\;v@R{\qàjmOv`0=l{H}`TljS wLvм;d 8v/vDdzHJI[*xl+y|saM"LmwFz=_?j&gx0"k -F]ϴ`?V#V/ye*ဂaF`Y aʍQ6+ :[:܇Aq Kj0=;pMMf/KJ3FpxҲ?jk&;J)ף)C.]Țod'DXHkj< i8sUQ}+Z'|w ?7zś̪:5Y9_#5 BsWq*5K +'<_0s]H iA Fk6a2KxIB5JמD~KW}恚&,'_Hˉ~&e`*|8D- .Zhݧ#4RHL a=by' U>@8O$!-Z7  Ⓡk$y`ؤTp_E8,;@SyEK endstream endobj 149 0 obj << /Length 2148 /Filter /FlateDecode >> stream xko6 [6E;wVVw8ͦᐢ,zM[`QF=3EEIϯ^zEj#z!` -R/VR^?| Rr%`0eo`~Gk=VLv՚sIXҜ'sqB^=%Ъ9a =B38QʏBi l@q:+TRM|>SuÒ0ę U^k+ӶT8Hu2Q|!Pѐ=O8왖y2# If9 :TBz]%9$ D_lr@9p{A x?`_ mWv Ic*S{qݐl@4;L~ېXg\=r}MdvfRи W¼f̉|b\ێsb/.}e: AE4/nҬKsOެ 5aC?JTPkwHJ&jq M51д*^8ojA=w~+ۚY+Jꇠs7MVt/d,s;n#:m6uG(P Ehkߌh+N^wkęW]o<5 U|*UBSB4! P 0#F6(` %`}ߧp .c9e{mh.ag-c =(9OhhN#2m*VI- 4<3Ï<c;Z4on3(EҎwOP2G- ay!7u}[!d ={IN@o&W(}_҇+=oƮ9omB ImFN=~̄7eƶ}䶙\AX oKho0 ֱ&_]T7\82 ﱹ2Se32nڤDmώ BafѪj ~L|WNKm_0x5[נbCݢ|ʅr'm(WxR;"$~uʵf% o'ysk4L+y6iG>ëa(ߟ, 'R%)ϡʇʨY.%NWqf\KeW%q X1z~qӄB&"I@Ij[cB6Iz7u$n0~&uHרE@iS /YPNUFDMfgL(qЦ]j0#B3DO1 ӠDz#}⠺z!dCi) VҺ9|+r QR z yztr']wm%:yxo?}8Krg4ӎ%sV-E;J';t"4T:|uXTzՋӚ endstream endobj 154 0 obj << /Length 269 /Filter /FlateDecode >> stream xڕMK@C/&`7^> stream xڵYێG}WmźF' 6̃FjڌV+[P}aY,R *y_"?rcrRΑB.IC!I%'Q=^EVz cBGHEDQ PH- #`H0nf,XU1qj<$* 4QWN& &r<{F4{ b^i=3%}'ٗ;]/}E~KI>/mN#i:US\ Їz2};|7Fgk>Huѻ= `dԎ_hnTh69hЄ%Wռ{z7h|7+jW9O&S}eCh^M=\.羨~ꏊA=?*zuOmniKBsX'6N$,]uj6ѻC@½M|޶vV,^vv(n1߶-մQg7|h|0\U/q5פ=LG֟AddnP`٬k=kt)ԓ\?H?~Gz-ג{-ג{-ג{-ג{-r3X8රt`mL 1|9c53 }I&dF4!+iZPcqpGdDG.@ Gcp)Q"q6 (e@wZy0 D`<F{-pd@A9 ,=R4XVB6]s%cKxD ]A2}HwXD h6wgK\ b[vU9X@?5[!AiЪ9FdtFJ9 qPUKJywS`u{Dj##tΈ̫!@nvA 2Wd7v^5SH}Y{_n$ ڮf:>'db EV,0tQ<(/syf҉ƈ8F6*w%^݇Tdy:y\^g*"4ǯ+ЈF Tj~a[NaғX@q9!D.vY~;*"gvWI6?vv} b>]'AO5%idڭ¡t8a/82ˑ‚$q'1 5cGoy=MjTbN7"#Sz'ە7튧u&{ · M)P<)S2K]Q^ƴȓ#G?,e=$Z ޶ sB$y㻈QR]edϏ"A99rWJFM'tv /_^"xwWe{k('V[ŗM/SϏ*o94Gs,lfU84?k endstream endobj 160 0 obj << /Length 1998 /Filter /FlateDecode >> stream xڵX4EH%I$@Y@(fʵҴwW?yqv{wHJ<~;_,ŗ]^=,s+g\nry9HwI6;Y]:[3(e}oo"Dڗ!-p__]J@l ~i@ȻƎRvB%bwcq S-̙1&A수gmgavSA[x3 Gb'-rYfQ?2،pXd03cH(~E#J Bo Lȑ&lh:Qp@!$,&qL*n1Vn)znc]s!VEx eDb0-rl$zb՟> Y㩭OYrY|4BQi .fZ16Nc-b%"Z̲e̒F4\iII;)H:$4ijG'a>AQ P5M* fpv-8;#,cGM+<+U]5u6 i<|rJniv옔 EM c+ap[wYm;Ieȱ a<k`},pa6}`E jʣQO6T+'6-~#pCa_ 5kPVA2lRB}) ax~;&Dw"]+rBc#_\^&_h8zm0Uy <2D0h ̒'_GUJXґGI@.i j\S8֧/™qj=Tvۈ-XVR*ܩ,%-L;89rh;+SB vX<;s ҟcDs~ɐ泱 >e[$4uwR1itaO"*:.7I!5**Pxr`C>B%M:v^4I5 V6Jg7]m8! &^r]x:.N"eϛ : ͚6iɿ [;vv+{0#gݯ08yW|)@b,%5=zO)P&uc#;B v psyNObD^+K ;[+ BmJD43ʻr T\0B97o䍟ݹ%NJHd֒I~+bj)ׅ@k5J +e1JKmJߑ+ 7uznЧ]6&0TAxLxcB%L߀\phcdsW-=KTxsQ!h_DuӭNTlL.Wx':B> /ExtGState << >>/ColorSpace << /sRGB 165 0 R >>>> /Length 3087 /Filter /FlateDecode >> stream xˎSrռK۰PGdax8Bh ۧNu8hYh{u&n~?}þ۾[O-7nn?o<[k#ĶCLZGWoo{h-oWuy7*&?{>lPyA>C/ Exʿ" }^%(9L*c3 B]\r"\0* @Rs* j^ @SH.0l\ @K.KquF%)t*I˜4Lr,Kb K.PkHT  MhH*,K* 5} K.fk\RZO_%2ekҞ-ns66U  PRb㤦ZT&^ևM-EMNjjQ߀B-6R'5EtZBi5EtZHqQ'5Et:EBv\X'n,D$\y}&cI)y &ݢ!ڦA2a$.aw&P ˢ>HS@2,Dd^Bdh{qe6j$vHA}%?k(4::)7I 'd^àd>-\Id_y i'n 7I\qK8\$q=pq8$. R .Ph!˂>HCK#tj$qY]2]2A&˂y ;?$*r, K-L$%q?w&˂y=7ɼH$. KŎ7ɼs|tI\$GGd9>$. 2w\>HK~:9$%%.Aj$%s9CY}+G@$. Kh!O,nr"w3.7]$qy蒹3qeAR|t\I杯3.˂97ɼ%9>d^BA2]Yd^z蒸,Iɼ%%qYɼr|t\4=ArrHKr $>3o\2o]2aR  )>dMI3G{HI ~yy&{z@Xd>~㒸,H.ˁ07|p|tI\$G+o\2]oh!W߸d>9>$. R 7.O.˂KKr $. 7.7.oW\2]2]I GR}eAryy焟K )>d^8>d>~㒸,H.WNd>~㒸gOɼr%%qY]2|q|r|tsIv@]KzaM-~?! ,|vI[{tA8Yw_}GxԛㆼA_l?(s22 Є,gV#IguÛw?rߕxg|^xO^f#›w?m,2zϬFUiޙjj4lw'TC;s⳶˧,_50]%MCi*W^垶WD{)M`hz4);Q/k[shY˯Ы@jʌ 2ȫǪ?}9ԆО- =ۮw8{x>ᔒnpݟ(]4M>3O?)۫^6[)ߝIoin{v9^ㅜWo]d ybҪd- ;+]?)db׾ÍTZw,ª9fz)69i'69it&La&kNVjYl=hps3X"}w^ٛ?NW=3W=Ly:YନCÌMrfV?:֙nZLf&y[yI6fajaYjh; MqzٙƮ9:ӈ>~w=N.90o[;flnӴkfZ ͳ$wlfb9fbӠe<ͮ8w[qze>vJnfF0:lME |&]6_ͤ(G7t[մE1EF+emf.8M֟b.[[ntXˉ2l?qFU#c?q3&z٭>0_p-hf.+[f0Kt~V7CT}6_HjHҟɞ͋$I< ,U.3onFhء;BMGِ([{`&6biY7t۬qÂqz%{:>8:mx2?̓Q?=YZy$$c/'|5a?dg=>8Sq/8xqfe/IˌܫiSҀhB[դe]6<=-{)SRw$=#= :30,;q1$O)D@l;%MZLdzG:dƇǕ fmeFYZh":[6EONfs8Cg:U#0iSCۅCeGe?ߓ-O='ZSyfS i3zR:#MҲ5a$d؆uE<(bgQ] ıc<_(s\Bm!=N/KkbK9tug,i endstream endobj 167 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 171 0 obj << /Length 2055 /Filter /FlateDecode >> stream xY[o6~ϯ0D] l@]n b˗%2n`?~FM!2)\D{=?}zzY2A<:]|U8JT|t6~E?.Jm':ßz Txv qACqoLޞY{ǩʲ$]q b OM-MܥSvJ>sz2=_$.Gej*-ȶ0r8Bv}sBR ZuΚ&* Y_ k9٭9Dr3 eZq_eQRa-se\XU lةVQIP؏XXE54)S>]>|{ h5L4Go[Ǟ9Q`'sӫ'v{p8Y(+j{C񭨢PCJ^G>4p;M.wFcM?nCgϙ$ɧ+ io<_5Mn]f (sZܯhyE27n*y{zǂ Y)|F\5~ĞJćlΉt$nB 7']<` F\NP(*&x\JF%)ad+TbfdYk}L&/P{%)e]`DBrkW]0әߘEaoVUao@!kf;B'Y[k@<])(ʜZNPƞL6Bm I @PMa2–Dc| .CmKD= ;*tfëCO1iD^GB ,؟D7*|msV13.bTT|u1sK GUov^??P.Б$֟]5~ˠ?.KAoӀ[ < :4TOhY"Iʈ,/S:fXPAv(X4ZǶa2D5a`rPPnrwB צNڵ.n_ fkCkOTy6xNϛꂬIYNSiw?¦? 15 " Еf'84b׍%w79 ͎Bw`SZX+hJiM:u>( Y0baf#q3lxƖ;fCR_g09aş:>MY+{m_T;qP&J'o-N+$ endstream endobj 176 0 obj << /Length 1861 /Filter /FlateDecode >> stream xڽɒTpCb-ZLUPd((Nܒ4^&NlHv&[$k8o׻^w6d_e2|'t^br(cҲ&E^uT%q~әt&yϖۮx@KRo/,;/RkpFI*Y IOPsPgJMok8+{|r}9xB5{>y*iNhwB6/LZ;戓"ԬG*K:6rȆ,)RhQz+t+CSEpd,sШJ8H^HRɁ|'UFMdvsŃ>Z:#z `JykqhICSw+yGfl5B̂4i9kP`*a_1FU_#8c='<ŶH"OVBFRkѷCe,*e_ )IL S=:>K]c>/6'A ~:{PM""vc9略Ғa8Q\Qy7rrre:D%=G? y*޺+YGa[cKЗj.jĨb؟MQgP'GЗ()+PWqu KT8[νZ `ɲqBK<|ݿ@zW ? XYtwhIH&.38[x!]k"Yc=Q~`,a6< tjDԝWCmfCX' H R:}t(ڱŠW gTq &ujTVl4 /Wt\ K}01pukc&,vYKHTJr*Z̙]zr\Q -gXVqoG+̅t +XP؍j{>C8 D}:ר۸A*,.7;>U4;(7Ŝs62ʇZjgKB;͎q4ܑQ|G?G2w]T(u\㞵I =?z>Jڢ쫽ga[ŷu*4PՇ|jQzUy`^>* endstream endobj 183 0 obj << /Length 2038 /Filter /FlateDecode >> stream xnh !Xd:kGenaPYo`YzXZ}^toȵ/׌jMR QS 잠t6wo%#6sSU@t @{<5T{BmF.z<Η}7w;grY+LQ{B7npfɍ˺Y^eArh*Q pQ, uvi;.\6 tyHVx+(N]/~d̝gP1Gt}@-X8{,7Am[FIu^V3e8R!AZ[SIY#0,*ߚ=du"p3m )ϨnȱڂՑ42% \Bg?JZ  zF'@х)u/_FFChTɯ_.s }锓5q5xU1Oz$f0Pu{݁?†K3yGaGGQ4ݎ,Ɍ(tW}ɋ=qވ9#b ;{D1OhE~{`8Sӆ^NU׋s16HɮRCx9\O|I|iV]yk1P ( G[FFqh#>-+H [\oUhs,'1>d&@eߏG+3V*;;1 v`*l'^|@pQiK -S8O)B[U"JH>:ta( #ȴb>] յHتǺGwΐbAmK_b,!0q,E@J3BtD.34p ֩׼y|$%G{D)n]M֡&+й¸rb7+{.A0Ee]о4wLP F_[H i.ൺƾ홼.*mdğjmǕ< ^ KXdYcPhIbpG+2Ԙ꼮ptM M?C̨R%>w%sUR72>Im` NMGO~\b9KO#P,pȎ%]X&Y2ɩq馦릴S˪9HkLtx \>Wa]0+Iz5vczqSZ&T 'ܵxfDt}:B!-[sVO9 u{|DCdԃ/wlR7ܖ:>*Y3&=$ΥxBD*T1Q\ M* ZE{nh+ǡ̠(l- Pb@tw_dXs? ڻ;*zbj#UG{Vں\A nb$*N;ŹzҎa 0X-K΂-7 5'?:W ;4B;[ԮPTߞV> +L4 /Rҧ*TB14iJH+׾;G_gњzsO$StP*&W>g`jYAq$0.>0ZW<&4t/3bdnKaXct)#A *sg4r DD V`D#)L!-w4&y=e$T:e'62jF#n  DĽԉiH#FRA#HkrcD%>q2Oyw_+OzS|n (_y_ގ=׽ѿr~Jk5; -.7{EGpLheXO?[Df1vs>Sj{l\D{HzoDy endstream endobj 190 0 obj << /Length 1744 /Filter /FlateDecode >> stream xYK6WbE$EJ:@&}-b{Nm˵$[w^(Y]-49~Hh9JG_?Jѓ6I]]T&#gD;^75졬@Ieee;Zm./\>{(5wOZ7WWߍK"MJJ+x|'je}|2TV~'R(%q1 K1RdjǙ2NSѓ+ѣ` Wv!a{%2Fdh?֣d-JԀ4tc0`D&e}K&9r}skq_D:[˞v:(& xyۭxZ(~b=ޝ}?푒8? |("hX*x1W7zTDA l =5fmb`E;$jG;9Qn\1.V3l-JX"_=Nk{i&v~/~!~b#52X6~&ۉ.<6qGR:sT=!m+\ʢa#-LС"OWF'+=h¶B-'hhe3DBMal^G4tc%\3R6GX#E\֦Y:14+:p8hc$5)RVKǛ!hczӆ@'AbAK턒AT}Hd(W~"`q<{M[,=[X Z+qTejX2sN!o'I^ⲶاeVSp7C4 IH5H53s/ƝMVkqr5R;۽dbN9L]UJ!CdFj-vC|[Ȁ}{UMr]j%YSAƠgv33s#^9Yf{gM\Ξ'FkRrJh' A9:Q)Eb 6q}h_ZDhfa#W؊F=<Д4,`mЌ(jv-աUUqBԷ{մ?dw)0qjֵ55<#o/*.04Q r+Jig,cdY2YBgo/C4<%%>Inԫ;ڬh!DMK_؂syZ\|,){˔,tm{HD8L7]MX/xr)`}'V\ݢټks'!*(w]C;:_Ofr1lkE;W H!=**!< Ңs~|Ute 6*; ӫ=fUtZASFny d5勂;M|6~ƼP~P~4o.&Z]hĕXo姑^lZlpWԙ?^4F\ 3m]*5ؽs5vUe.j?﷒׷=}Y;=mUl]۞Q _.N~+2quYƧeJ#s*yEtKB2odbO AgZ\!.5ެ1ݧ=n_eD󷌍Kv)*2ʱ)xG/QwD.c,2(ۙѿA endstream endobj 195 0 obj << /Length 586 /Filter /FlateDecode >> stream xڥUn0+xhBWآ)ڳoABFcujwH9X4gޛB/3Ϗҡ Az+ڊy-n\eWd.RPZCrK6OVZZuaQg]@8@^mn2Pz,~;1ۍ|/T%Yc!/ӆEkeWYiZwIڤB疼iiZyod5肯Z=z1ߧR^<@Rh#=ۦCt R endstream endobj 199 0 obj << /Length 2572 /Filter /FlateDecode >> stream xڭYKPNd8ְ'؀w }PH^THifI{ݔAR?jEEۛH~zxޘE&͓fyȳ"LLxX/~*,z$Afw\" ^;v÷ojoi ҆42]*OrZ *2*'O3[8,:kUR=R8YԺ~ءgRf|<.,DqNLg"eq0\˒$an%= M\|0퇛mN$˃~q}bfhߚx,ے+d ZFaЈ*kJȽ #!|p YPIuj[!&[ϲ2mSEpJM| ň?60֋^X&Cۼ}2xC+:ز\|{t0N6-O՝4R$*}eDCl2.lD8-m(ҾX%M+o"ɱz$Mk8Jڐd#&_A$*LJ{r @k`pG@[gdz‘bP[|"Q k0ܐoeiVMEZ`]E9IN_F /Y"8 [$>jb i/W;G zr*IސP'EXmB)U˕@kyf_.";40+B.ċ]"Д P![OI)Q<߫&jOeDox&kߍH'6?/#9/eu, u=x湠m &xZBnÌ8꧖Acԍ P3?ʉbȪ0ݨtw(PRDYAӧfsLif'PR;mƝ<79Bx[@; D+Ez'&S'1~Fcx)i.#*=%lrH%xxv'V&~5yDu$3%<,YHjwlL4fGlIA[ѮI $Ufd*a8r,SY`k ӆwmnס$&RvTte@jJI0ov4%| )(ڭ='Jj/ZQ2don;;&DCAnZD ϫ $Zza$pDTN{Ƀ$.1*[p}RGȹ &C!i 3y #uX1~p7}f$rrс\p7U{u "ye 3. ۥ.aa=g26a{BbHyrziAG^~v[ع_vEIcpJHݴ|*";11-T} xjfR@8([;RhVu%ݗTaj24!g!KVJbk/̤ IoL&˅[eDosr7)?<t3gT 7dЏ,JZLzZ "J8/JП`CQ$zaE]ʳnsa%fxtݼ? Բ RTю jz^ٸd%x7ul9ͱZWMs `[s^LrUȺd:[nőipQ$4u oh˞%=tt׋Cأ|,^|4'oێO%"A;;4 |LP(܅d#Y> stream xڝ]~VoH\h-rZYuI|-.}$pmڮ/x꫷YUa~Y%*ϊ0Nf!u?-<|$=|Mfu7 ܎gul²W( L/-3a8%h<#7n-<<[x&xDQrbv(X92oqē܇t~>2ߝMCSwA漆Bg ΌW!o`IX֕v4':{NQiGAދl򠓾$C$a'?WK^3q\SGA4."d)/_q\؝XndOW2yp9w#t+ Jxp\uv [{듣aIk,L$tWoK?a &(*x}N4h=]wfs{=uq,e MHfj[ZېӴnE8."a'ڋc "э($rg"]*0KV5G1)7h&?(EGV݃L, 76@j0,Yxyn=qе=6=͒>+ia FyvRpPi^d#yw(ˋRƵTIG0!hIҰ&ԞϿ>YXnjQ%xTEpyN6&̓/fZXlP) "͢*ֶ[N^K~'"/WL;/?negG/#S]o. )qN">'o\h~Q0<5sÀP}|ܲfCYYȼȲ!6PѢ"H&)sEJ{_7 FGaTTޭ6;>3UDpց6aDS}"ֻ̂#y ǏɎQʻ *0Ϯ$?ua^S,"LLq xdTإO-;xs 4`Bse/ E љմ*fmW <<<O xA7#C͡(#9lnuYQ%F3$t936G\r4LMrBD67Xdݠt[slأ14R,ʎLu o䤠497r%6q͖&ħw1I ,/'Z Wa648||+-ivMG+2^+m.tyyjqX:;!:3+Jjwzi~ISAhJ$.eU)q*d4ij()1A@5S[Nu8@ҘM#@5aԃpKЎ߃GmP@;wf:\s<&Y^͒u*8,LE'UqAZR!-G 7ىv|.7زH; "1E%]#)?,v O6*Ѹ/u$ rq,p|Vm n+gdi8Q6F Ie" z‘)%+kIcm*[&H?d^yJ.ʰ6$ɧs2FIg$ %ajE9|b-ǑV3,5oQ}ݚJDyfE1bAp-Yw],Cw4^^`$r9g? G˭7=t*V r3?G@&kk@ :خ c-rs?*.ĸP~!Q#r.Z`\{97sރvq0nh)%+s (! ) Yt^@ ,*g0޾,. endstream endobj 207 0 obj << /Length 2385 /Filter /FlateDecode >> stream xڝYKs-d<rۤMrHSeӯygw7|[䋿}/lB. x.1+EYLbYgiZZ)mΗ̏n6.O|c=dϫNdsO;iW%YMkUeR =)߰EknN;gm(߸>bF<ibQ6m 6-;OVѣ\~l+†I ˖iލP(_rYY^,hGܲ| [TTAW_& 3|G4y~xҖ#k$KG,[b::m̖0d# f|[deJ_a|_fTiF :.I\M(ꥸG?`ٿf*GG>kU O-<GrLB|$S٨#%JxRi9T')l'H4LPNj[ںx)11z@5] Xy=xBB敿['8L6N1SJ |t_g7ӱQ/ga\ju5Pԋ] t@/Fr)FH&JWP5ҲzDm&E!8\ױ!9Y`eV`g fwe#NTxeUOߛVa,Ew-?#Mj 7fbP%d(-!E%C!&re˩ I [>J/|!]4%#R (:J5MS$"g⑍*SSTtA9 zh8эQYkpWqƿ\|^U_Vy˄JjULމÆ3\#~Nk_bwmT)^A jZW:~y-k^؅֡rl1X`,1Fˉ'n)ohuʘfJ )1؇^]F?!L1FB_Tonr_~r[g|T+6| 0T )aЪ%烯>c҄ ECBx&Ye)~'<ՙ{W}gfe3"E: !h@:1+މ5,r>7;0LCSt;#C^XͫAo8-pzUGr( I\]R\@-zkחD PskUƞ`zT_Wdݜ6XZ&+e4KlSx_>:; gTYK!V|{M;Q>'py+`P ܊ _E>Υ719J)qUZ Xl|QNnFRQ[ 4*g{1IUՕ|sX?Kur/N%ɢ>br$ endstream endobj 212 0 obj << /Length 2178 /Filter /FlateDecode >> stream xY[~_Nܮu)4iP,Z`1Ens#E򬃢E`";v,ş^$ŧ_Bg*r_4UE^.r[(zmdF_.utkkfE֮ql#QC3?uTLѪLJ>쵐,VP@yP;sYli-giEe=4x fG XVjn<"qnTj*+i(4~e\NL<-Mu8agޡ t{ psݒFq}脮mݘ (wvw"$.lZl-{Ɨ# dJ&ZҐQ@bU AKkfUugCʉ4y #(j! &yw,(ν(53Qd4]#Q4#\T+Gҫ'nxJi8ڹ5̮.UUxb(EP"Ub@=U ()"Eu1y=xAδ>Qu#$*_ERD_ BQgk$CV=\z( $\HSQ}؂1ߦe;2\ u9cCC@HDUA^}6RfI!H!A7nM3\J9[NjtkJ` ,yƒ,pVrtbȖJT ]f%DkyP;wP#g9#n#6ɷB7ArΩm78S ˈJ 0p`$5M8S F,*UI^]>i+ -廁\M}80 _n;b,P}(<5-ya-hCܓ%M &QH&Bղ7ird!5 TE \Υg׽a/hlĖvH[{IA8Xbvzu.Zp@ޏu }Q>L]o$ uA[D=q6K4aКgNFϛ}+h_2Áp#5;^cVA%:%=hbR"%摚[w; 1!~ a,}w\q ust$]=zsZ?9c=zy±t_Zsi#<fz,|E7:(1ZI^jf-'\߻6F;k݁5aN,<@wэ+9[yL'iЋ{,AϜꜻ1x^[l\|OZ0ڠ9DKi0ʡ-a7 33x^'l||:P|l yyjT/g V/o|~=n3747tZIHgԥ' ۍ\ܦ zR4dW/wz endstream endobj 216 0 obj << /Length 2176 /Filter /FlateDecode >> stream xY[oD~_UH{|G"RI촡I\dExmnxsf\s4̒ٗyr/dMjfuͬ,Xe캝u9/Tig -rއB7³= WOOjOM\,;PUxD3tN~'ȿU4n5ю#6hz9dwջVĔ ܇ ,.UmN@s`Kf윹,K4d۞%;QhVYb8&B-e_b>𜝠G#Zwu#Ow0iytTNPe 29,裬|qJc$ds-&mKNk< WG'XƩi %jf XN&Oolb.*fj =g)UbNb'߁qe"kRyp" -|0-DݥxFG\zw]Ɋ7]̪{*e Pʣ hE FL,|˜sC7Ok2+Q^ 4 f?ĘdgLؑY,P I{@2&MI'P2Y6Z?pu_5 x}Ò\y;2R黦 ,=!>VG풸Փ؂7t2}VٿƊ=&+n \YՄyOѧӦ%;ӊ;$۴.MAEW^N7ؤ\< \&a LQmJorF=\-E{zh'֦ Z^Jֶՠƒn|ąutbdDA]+94ZeM?'iof*NIg<8xKgy:hIŲZK*Y nd AuReD*@"$"LwwYoj)JͨEn, y/c(DO2X#ME\4tLh,*do";)5u=¶hM#Ռ05LyX0qq_M4Xh׶LFB2}o5bv=H.T#;yq֫%1 %I\& hFCD_@dչH~-t? Q `GꞧMԭhRI6v);Ўx8 :3 /z .jvmnV7}»Zi5v8p~[>yd*:غ ,-˸2ΛUҀg endstream endobj 220 0 obj << /Length 1958 /Filter /FlateDecode >> stream xڍXrF+x`&/r8qE>$H EەO,d@b0KO/o^&3<_?bO $N'N<b˩ةR;q;K[J2fј9+#(Bҝ;ӪF&,Rwn [ҷ.F ('C;E 9ܬEW  n5tiㄽ бn +g˚[#0ex*,Ÿb6yƴ\&55xc<3,ʞOfO(Sp^ F|O|37}^ qݬx҆h$^sYXoST/Pl;f<ȡ bo↠72g-kTo,X'UiL捱ͼDJ7Ba:B|=2ݙ> stream x3135R0P0Bc3csCB.c46K$r9yr+p{E=}JJS ]  b<]00 @0?`d=0s@f d'n.WO@.sud endstream endobj 227 0 obj << /Length 119 /Filter /FlateDecode >> stream x313T0P02Q02W06U05RH1*24PA#STr.'~PKW4K)YKE!P EoB@ a'W $o&| endstream endobj 240 0 obj << /Length1 2190 /Length2 17157 /Length3 0 /Length 18469 /Filter /FlateDecode >> stream xڌp Ƕm۶tl[cLlO4db$_﫮~kkO5)P `ffcdffPvGG tqvt C&nauX8yYx<1ttxX@W8 1G'okK+vf@ws #;@MFtXoz`ado{_&ffN& k; @IRˍ``ㇿJ7HL>+_ f s1G{{+_[>õuptv0;PF6"?2Kt̬J/_'G' psqS`nm0ZZ;!Z? 1~,>}20sG;?:b&)9m %ySRT ```p>7#r?==^Rt\ Ϡ3s0}|H_z &v\w-Ppk{uENcD,FkWIk/\Ev*;ZuXcl?׏ dl?(~?.$xQCQǻhGoK_;}?:AY>xi_72|#LnV.@7O8|5t=@$c ?>"]N?h ݖ4[^p4 i|d؟ʠa]vJSi^$uemWNxﯶ&W$)EDa ԅ~;iۂvR;s#)?zjX _W9唃aӈ.(0͝!rc EBE2N,DV쫻4^ڃKC~66M+z&[V)0#y^N4@%A ;H狧Y٤"7L"l(:7Z69^snZ^ {{'(Ji)yT E%q a׸"_ƒp7{ ^/MG)g00CPx"wXRZBeXE*sd361] 4T͵OIfvUUc f3 rxyig2 4Ϯ.4ݲ%cPkeUyʛX):[meMcxLӄ]; #{M~K} +,}" ![Ň5ͨH;nxIIDQg05""VS|qcXn^k;JC†sHQ__sI+7WIBe$ha6n^m0ɶ:v% @Y;Tr]fqDZRo |5G΂;[#ξS t_m}B%C 6\}3D)YŸfv?/&[|ĤǕqB䦍 냭LiY΁|M6СYpY䦺ha #3G \NL|ZBp݀lt FDm/ ;IU$Obz^c^5}bdd(֏ZLW!Br+y?P[Mt'5 W}\ tQj3ƒY Zu6؏pf6Sz@-{MYCYZfoWG伾mcFK J71X&-TO(E<Rv0(`d7 xɦr;ŸukzL"US6H];u:ZG#. bz<+{U`9MP[M%e!{zK<ٝ,fs=K% 풣f -q|D'R;vr߂jv GLzhE˷;/+o][QGu!;u_5Z2ϳ( ~YI沏:HRAͩQ6v Z}IC5ܚp".w={}{;jCϑ:~іݴ] Go*2yH_(^m(-@~K6M}9FDː Bt)t݅eѱK.IY!{[nvÅi/-&<\E=Såh$MF .+v Πqۗ  @-gxLea#8'}t90^(|XܺNth8ݞC>F 5fߙTMT@WH;| aOoo?iߓp,~17+B  sŶ-d/1?ң=U"m%?rbR 4'§G*@"f"LX'>IxwDWCkR0&D!b;?;ې-U!p`GȄT،J_Ӝ#"ƅ7 6{{4nc3 Ϻ Y?FN:4 To?yU@ʋuNЕr%`. 1[>]yQQs7"X} HiUğ㤒'g(u~kޓ*VгEhrZWeA_Pu^ 3So+1MfB@=CJ*rt٫(^|Hp9fLGtDc- \SXyjYi$>::uGwL2Ʒs!ȣ,8SG^)/ (Љr}M|?x񳛻^Ӭ؋ >F+cU)g{b|8 7,Y#?e0~)m5yՎdS&)~^l Nv Zu9neɸIMo4D˔ KA)g uxʡJt'+bX9xM%{iu)J&'Ő> TeNDt^X>O,LT&_ɪ̌6$1E|h6V/ 'wCz5g2aY@irw}RxqQ.VC%a.BP䑽GW%V/vzĚ upô%| ߾]N 0J}.BYæKrB$?2CzܲK%:47cpiP;?$mAƅB/"]u_~蒉4%7^̠%U+`?- -kUg2)+6BN2,x챂% 93Qe+X3\ʴoؘ2fKQX_aL?$LcCTb ah;0r}3=psLVꛍp=V WɷpWZKr%67fN=»l-_mYs#>Qp)N\$F +6`"cq"4V HXl]2cr*(Q*]v%6(u q˫*ESZ @J?.y߸Ky[Qӊ]Kov3ά2[k ݧE&l4?Ad!Y|h%p6FqP)\ЇU(){#+4ǟGs--(.n~6ibV q&;NoKm._w*ڑP.]̉w0D>)XPzGOVJjNtE$"OO gCC22lJNȲgf?/4jJQnYaɔj f q բ[ƒ#HB+fVt[8N'qf\4x?p,mY C$G¦}5 D^a7m>L^*6atu`Qm+&!KƋ7%e+\U'j~k =f?~kyV{ik$q ㊁_C߆/5S#逢9nBP׮ޜ5_xn`+˸A5h{*/rwOD,]Ezy5;۽zXڍt,k﯋QOF~ wŦ(8M%1O 骟&Ѕ>ZLƽc`Lc6 &pF27]\} };uy8] (ԫ4&mzi"U+.T{FI&ٌR+k )s(#l(JA0H,.*"qe`7m&uߝѾw8%L *ryK]0*hc\qk Tհm/ -x6ȼ]e[ .?|gq5*¥ge]zX>6p#"m9r;ӧ|\GcS@v>Y۪wx҂,Ƈ@\ޝy +|ʫOHrsm>]I C۶:xDث)UA-DbRURٓu.2w'ncVσM:d+ڸqܝ ۅ8.ph\+NmkT*QsO!eJtFۇBqc<;](`0j#kf,uTl(rWR{waV=3TXAX P6Tm#04!ؑ2fܜ#𼭦!͒lky%yFy^ޚ_^ ֣-%Zײ?]JUcL]48gÓP_!!c @J| :8c"ʳOMHkf =zD> [MO‚0nPm Twz1FEeV8_}Ib=?"orm\:<Ŷ~k6\ Kn;A`ܭxa ;>G5/0<:.Bj`kmL M;HEb2[GN[Y3ƱQW]MyY w|œ.h`ReLn^Z~?a|z?:-*'-Z7PsqZr͒8L$'.4i0vI\G)cUF"/šS I&z( 7/f~- K`57U6EнLve/j}Zl_2x½`+/ME G gvۗZ`z&w y5RƂߍuT|E)Zs=bX&^=L_M89J`fL3-q)kfp3\CC AdBfGe4q% & tUT22ב1/30UhQpdX;;:5qԬJq6|/ir1hX 9Oޣ3IB"  JC KsߢjD8Qb(wפ-O l)[ [a_OYZ ""Gĭ"'= oL󤉺9󠇎SJWv?~dYqyA]ݏdl̃Hk=H :Ͷ\=oKb\hNLN` 'Ѥne~m:[-SAim6 ȱ6A/}C^բSP^6̾'<8y2C3|ŒO<:7W`Aw)(ܱ, Ybゎ=?P O0vtp7za)X]4!:>POr@rk:n%k N^emћ7 (\^@ky0K:63JCs(n!vJZg r)O`A(^Ix#ŔH)?)8N9OF+{*g8 :<P3\Afkyds ݿrZ3^ZQIGGfj *[alBR97n{,s횕rzWy8& .uϋ^l%fp",Rx[JTI <ï7\7Ľ Ì搋Փδ.WC] cu.sy=6$rrF J36tE*1\n(uY;C?qyg@Qjǣt%ԯ6d ̼f(0@i_ I u!ʇI=ܶ/bH`Y<'\vHľvB0EQۊaȹ10K`d¾ib VC@ BD^-}9_EڸGme=z v?jω3qVRDvrA IqRJH?2+Hؠfc+'%U#H(NeD9ļ &c rVG>3eOh4X ܬ]<OUf`# g"2S/{;^UԆ*}WBPCR/a֏TC*٦cqڅ; ^L{JE?3f` (ZAi,sv׭ozdF(*s-m^7s]}8)juK@kQ+sP1DD,d*^yz$YLHT(g y;XI},kĤL5]^4D1J,O AV+n$Tq0[$f9'z'̝_KD[FkG:<(|($Zyn"F%Ul_7hSޓK}:x' ܙn4*gi(^t< ¹ :3>M(aat<{?HF{rdd< ޮyeaC 5ʿo5K7&XcŘp(PR"6k- $PFl=D1ԡKk|Rj:wİlpЅebDFu;e7ڲ^Jhp_p"RPYwd*3Xwva8ֈ+&f58h`wƀC@*ZPI%s5-W#;=OgqG9XT2DN-47n:ibh"PNTl _5LOD{ *&լGf׷t0TT̽ |S…B;a' FbޖcdށZW3b y][>arn嶇H"mĿYn{1 Zq}'gݩ3RYβx 6msZE~L uS4NMDt ,J^ AXY'<\Dutn&O?vRO>ŚmJ6>X-M/`1[R| [}v#V-v i>?hЙY9AY5a:u&H aU% f(=|O+C$J-;FL%rXYгV!~Ⱦ-+ʥXH .xP7{ R*m kAn7ҩIB FW܁IQ~deEhn;R4E 4~Ag=+RtOFyZM\I Yy_'&IbQlʖ H#Ϧ0^{4 Bp2Fsd;͙^^Ү}9?%Y&ɅwݦEIRqܝl dWS^4FȁS+¬Xm/rw;U{&E/_߅H736p'Nؐv#SYz6'6 P& GےF+L%_ђI8~.: \6^L{@1xFY]#yD[5@[i#DZ߳ҧ[hapܹ 봁9&Q/9Ftgz5U4?y_qcf7Em‡/[=x4a']Ѡ^z/$oBͼ#+M30T0eMtmg-jfayq}0xL')=>S b ;6 1ķ$^(*AԘdP.q%l&"kCnR ~jnb@8yg*uH ]yx=կ+VܐJ _3(LECxߗ%0p034R [R)9KrBTXA6̐b>ȣ Ir衶'aۛph}4hao]MlɛtCrA0s< l)O'u4-J%U2!lIf"SMEw=^ Qpz4X>)^kK|aq_݌e bD[5puB*.r=!GbO c$# Ƿ*A>kyX-iN\|-#? ԯ% |.;JRG6C + [~d.-Leilxy'qi~4|,L7#14+7bOIKÈ`yQ:,JKiZOT,Y!_!_f[|,Ņ.Т1Kņ?m>%{\$[w =NE:hغU:I.,Gmci[Jg-WU!Mf' ,=y-1WVctOhNt9뢤"bTaA&΀h%Ӽ0/AZӷX#C9dԶd# A#]Bxs$oi aFDr ʱe;as>w#f/yx?)څeJaW2 NO\NuE8t$&c̓:|ӓ~ X$mզs;P?dRe8{k•qӤZ23qY?~'L #^lK*.MK1[ < N zw_;T>gt4X|hSoЭX?RQM_Q.SE C+0XLŸ4r]RM5n[M8`("fA!RzMGN'OMGT Xh3zJG!);cϩ3&k'Q~Bz5gavcKws(Q џ/_L>72R O>X> =ߋDe@W*!F]XN5>PVww~mplrԶBO6â$P"'!W;Ĺ_SH1HWumtG m%-f_ػ (9%>9}Pd=MҲ,H[4ټ^Z]-K܀c,Mi2$Jtlq1+ШNL *z`նhp;X*er< :vֻU[O> ‘NOs8C?4Dv-NZ~Cb=l`ygx!KVf0@OD$cJ.L\9{w3>"AFAyN| 5Sꫠ\{Yќ^=-f7.’]ۣ. Sz23 PFj#~>b26X(-8 ` Ka] hPy|{8Ʋ/) G(Hmʞ"8Z=Tvǽdf͟vOa m'._vǼ+6^Si'ؤfHi;ͧ{wSDuDFgs(t7d1$ՓX6;\m'{,ԹBwG"1i#̌D%<[`sg7W,C~tSz?GW ڑ_3;X4k=&Tt UWǯNGCqDo&w7cHLx_N"h P"9H,23q-Qgۺ\N񘊮HجLΖ0zԉ/FGrX;e6|Ib ČF3zi-_%QY[ I^eP&jw刲oc%pzp Z'z! ֌)vb%! )i͞Ϝ!UV4AܣY/ѡˏ!$)#uo7$ΟTMjFWU#в[{4C] =kOX[ ֔{$g}5+~Oיt|S^4tS)iKeBpħ#Q_,֎ʱ$L֬]5_Y>k-ӓߡB˪c -)nio+|Oح`*ªɯ^ڬKx'~FP'߽(fz*x)>#]UA藜C[) ?VVc@6T>vzMP5e67V)~)Kή/6uSn%yípf׺^VCrmv!ăd;u@}Q0[g-f cHju2;tL-3qs/F5"i̙s\T-EM0~5ijU ztD]t{33I|·yH j6WH$׬rs F=A9t JYXyV;]}sC2g޻|);jˡ䧉/OdrEy Q^j.zUhΫ/V qTdD{_P yWSC7|JV#4T^11^,ft%eǜ XFt9Hۍֻmar. myRikPHA&Y )_7!}ȇLAب r F6W]z)WI--A2)Ke'sX6aHg\f_mVw\]9ڗHf LkPLݿ֎s^d xHZkn.%jاf"CG-EUFcⴏ4gyn#js&[?bhdcooȩsF}Ԋio]Zl*z[:<*nP6R4s#t1VRs-ևIUS*Şҧ(Sk2Z6KPrCp0^:r$T1llkl̉L[d" =6DJBzTD' 'Hc{ѳ!3!MZT$ ՑH~Ad&Y4X*E Riȇ>[_ biKxQ vmRx3g;.,ì4ai9.J&DkEހ[VHhZTj_Hb`'ICٙs;ʇZVceC/,޻6W 1bz@*Db} {9u]򼉪QK󱐫m-z! Lrd؝9v ZuEVSCeËDTXOEq/L緙T!9`Bgym-]Qe* d)GrPЮZm#Sk^Cpj~)JϤDr*a0 Y{Gn]`F6>1"cJ qTH_Ӆ9Ǿ71(h{pV ?-hJJ?-3yfYZqh@G"LMR Qy% L舷oP0@^mlFUF@^!N ~*q[uhԵs) pfiָOm []}M:ֿԫ a⫵^GmX CoqsnNDK~f]̱mB^8x(qCW⸏G&]^mK?d~w'-bm`SH ߛɿ=0hLl)gCվ kE߼"[TLm{Jx<<6tS2x#[-IX endstream endobj 242 0 obj << /Length1 2068 /Length2 13815 /Length3 0 /Length 15074 /Filter /FlateDecode >> stream xڍP\ %4ܝ ={ {G=ޫckεD^^Z$fm@Rgf01201 PP(:X+GPٛZ[Btx efV33'v<!@ imGq356qxG5/w%h:,2-J  Ak`g3槦8:A ;'!7e,75 JF@;M`ajsq2޲>Kl@V1 @V9 -mVV#S @NLŁ2m~:M-o *o go`gj``oj#0om2Y9#OdwWƿ7 CGF+S[GgmDd ;'7d 0NjK[`FijzAp:v O+!03 M  cS+? 3uh23' 3pc3*J(M @ `ffp3<7<:~2pܷ>dgo,Y ;qߔ:"1G T1-M-\x\G-~k Y[_g.Z[FS{1S?rߋfaj7}虙m ߮Kz[M)je`m{X9@;;+(ܙ\o<FvO([ `"7Q `A\,F?Rb0*AoUAoف ַ@KQ}cc&towG BO49oݿL߸޸ژ]Λ_h/_ſW?ٿ"]*rپv~-[cMR`u~1f~#`#oJ{-mgt0oE;8[፲eu>oJ/?ahg^z[^B aecYm@} 3$ŮZ25]/Dtv#hk;T7Vݏ[a[=tcgv ?y_`D%8/} LAA2^,e}ܫew I'Ԕ\~i02( IGLJWs~p)]n(}:{ 6lw K5A3Qf<=VPcRad,J՚ B2~U@`~Rh.%~suѝ<dLlaa@ ʲ)sFZ|^w(U$6R<o2O;\*rY!$m4& [ܑd׋z}Z[j TZg{{ͬ(h=%2AMwQFJ[]}z܎D6Q1ղv|&%Q ~"+9=:EM?'Th&g-ݑ(pwUXm#FYܚ`H2pi-sZOƱ.m>| ]# Ky|RA.8rIgglז4Emt~h 4"KZA`A^V) G'HxLZxFHivPˋPr^p'QiݨF)W}#?1}Iz+8HZ:.e+]<4)w]"Sҳ$}-F  2 c@I}{|%AUD*2e^mU*ɦ 41K|Q+ -:pmkvTU `uz o|. E־\w`n_ӭl|yNf D!ϴbٳ qvJ+<uÿ6+:'6_ 1d7CߑqUy‰VC/%KlL݅co'rAJ@?!IxU WyclxQCq$gcN|eoL5{`I,y=Qv:!05-nyCf I-h%Mx.t3Ut O/1d_Pg+ncG}.S-^6 Mky^[=5}}eӊM8z~Bfe!a!06 F_c:!5IsXnVUw@gBxeC62'GbpW[ڭ YDoch=;3Ft "y4jjEZ9u/{f9Isr#g.oVSQM˟nwXDsOlmQ|-MKAF>iMEp L*wD?;>~w'e#(mO#}Qh rHB' λ0>/1 N w=)ݰى,hY+0ʚ;.[x.Ie0IL(ȁ;k.jҗF '2ۣq80pvD5ۨtLG.7Ka/ u3oEdQCY.:M6Qf9 փiX$@`ԑJyj* l" rEsP Б^g=RM%F9(->ɧ=u. ,YQ;QZ/If٧3SsnG: 2&#I}/H!!k^y"f|J;ջ65ivݾ/CmsN54Wgܠg?L=BdBѵxΓ;{p"Ίfzj}lJ:^V-)2t\8ȃ/_u0|]qٚܩW&D ۬AGi6+ Oqүd6Ф]R(cQ 4 f<_}O)pXP+}7T*1U;﬈KG$Ųes lVZ9 ?ꇮGnGZLzÛl n%ʒ0msgQِj h2#]cdxęS7fMHiD()HjCפSQ:Ky=*C9ok.כhW},e1b8!NM~0zJ<< {m2u/wV_+6 06;u0̉.6r#+1J DneVys_CHԡ!eDf,H?1¥M#W @`qL #z\ {|FIq, mf.UF*Y 뤞a,ĿM~'vtYɐ^+ԸRW $U%yx6-sP'〈Pj ^s13nBQ)ƊdVU!Ws[0k^V!w-Xb3)7iVzYR ';Axq9{*߮lsQFcq@i\?vhU!8Fcn!\{ںFABL=Maը .)Z=9uaqRJl97З0KxL9ſt@t?4 ܁M#-Il^r7Wu,vU1קᒂBRe0[ӨZYs? ;N*΄K&m퀛ggn&M: ?.NmGpL? ѵ,4޿zuFѱgh7ҭ]!I$[sLM[|uӉO%]2).75w剑Йԣq:%ٗ`7a[f8u^niZ`&AO[;yAдB3^nw{وjX 좧Dxk,,w TV<-e=T _Xeܪp4rbBJ)&~ 8vMWyi (*FUȫy4R Iܚc<Rw\(cX.n1R:nwtDŽyCq1ëOP8V=.Uj5YJwܯuކ"]&yM|'0&C !uyA g"LŌU:o:r}N3. Y(t;FCu݅0ѨT*}^TR?߭a/7q)r G{%w*Tw0D'_d٦uZN_r5qݗZٰFVDPC .R k>{$"dy-UIOz,sV,O v$jVCW4vK_zqryIL}iFXkA|G5 0`<%k]uqXG&T/wr/h;C1/ré{hF&)X(~#xH%LER홍%#U(ؤsكk9^)$o=򜪒gZUzVϡspy<5&Uv#d=܇Ǡe0iY:q/>Zd0RPU=+BܫwIvU,ژK+PBkvg}l L4&؛mYGqÖi"ZR6t;V6=諒Dh=G 9*k]a0a٠ jO9gYbH'$V0`>2xGH-YiNswj?'y UcL$*p)㤍.pNqs#Ԓ< L T;vCO;OG] 4(M"4v,>qp5G8hs,:r Ӝޝ*azI}k6 Ql[)nº8x1Ɲ󋔹ia-+Msp)7oܭ\&ZŘ׈6CL ria!d%dg}3:18do'@?W뎝ԍ{+g fƤ0/2??Zo?fŃ)2%h%j ~UXF5OsJ]֬F?$'R @QOh_{gUA20U'G?xepF|{QMHZ8)I-!@5Dӽq~QADBq)1vK|{j؉ NcZbq{ErfB'=$sM=.r .'HM/!e(KZR.?`:&eQSu?P":{ռ^ GOO-WTf 3T]X6ק pNd#+'ӝO*}B>}e@n_ g/X n5LX@C"iiF!mD( fs,o.Fi [+ 5L0}DzO8Dl/tK>n>QSz5C[LsfzmE!j熦 @ `Ktlv 2AZn0EIus0,1oH0}\wQ!'`k|^\|ʳ#w FwzQ3 X^5>.~6II["^LD;VŋkT82334Z-IPpmKBMbE%sLY KDP.ae ݀w*:mSqv4.|65Knk>0a);(}W<\Ty%ë=CG/ Kaِj0Ky­n#m##wzbQ0G7I^#2 }~'\[j`Wrߗqm>L|,F )9*Ȼb⑆Q^-sNO+uH谩aO'cIS婶퍃ud mF|1]Gu^ʼĘz!*C|̘7f+"';FdcNc' S,]hS^Py1zr!.MphfTLomMIէB^ 7{\]pl0w0}z5=da7CN\eIrui U)%>pr^o0N#`^"C?ܤe #|&D'8Zx3G⥅mZ. 'CvUmMÚ [6bb ޏw1h- =_Sl+ CuϺtL, pZ|?- "eW~wɹU?K1MeFǞE10aNwcL(ۆ9rŘ ?}S0ߖW?tܪS<*ħqXF>8yU/ayZ\.tfrq/gM/aˑ-Wb[02/Nj[ɧF/2 Mytm e~`Jvpq؝{ub[@ }ȎpT \[rkVQ\k&\j˻e3BQ=Ox_1ۡzM0vh70#qheuI#f eu22Zh{%ÄHxV#ڶ4smD- rGL4Oqn*YUF=rB:H(Y|k̋%F-06 ̔Ǭ+4C}z-͌n'iSY/oӋ$cWVP SFG{lTH* >keK2~N_Z]=O"ZWBc35Pf| /4C5)`by&uCE>د$6%bI w![{)NQ6>[<#3R+ЁC&?"#f$>E|j\yjs6׽ ?Å#޽fͣm}k H=eh| _bAf{ےphL`6nlEcHBU߭_nR͕X4*n gkgVcm>8N#0ۿZ;?r& ڸ]Bo,`Cg?vɘ31N挀 = wR}1G]uTÏbWW)9EyZwW4/Cd;,Ly 55[q,rlFوT^Ӆa"+WZm"0.íic/|$9Jҋ.>v"jY !'7q8i2, &X/~,gkZv䫝%ޘ#M/!|d. m5Ð&p ^)޸NCN{^5KI!yMo3xxG-VyO2@Z8duFH5fĵTeMz~8v>owqVb23!]}8x:kgq?Φ 8%( @?VXKA[f5 ŝ;j8Ng+R3d@2c:&ȍU0LQ6 Pin۶OH" Ӗx >^{cV*"8ݕv"&6C?kԂdƋT3t4:p]_N] P*ѻ@ {= (՛!/ ѐ _ ozG9f {=\UהŭIkH/h hOH rڃT ;S2 LiaJe?hqz|Ӿ_™Wu,3ӽBB?D,P+ٿ,"pIVd5IUtJ}0Q^)kC 9b5ǠّM9êƣIS=̭SWRl{xdKz1NùՖNN00ru''3.ly2 w_b}5>x'TRq0A`EXGpJ\he E&P1,\aۀm C+<eJIȼi.uom`gGaW ~(τvG09v왔"/`IG)p(R!۴J^hyh `RSY ܗg%iaY# mo#ŎZۮ?ToNG~.K@<w2ߧ >9-WfHÏ3M.zo"k pΌ(V=fp5p, FdQd?X:OZ$N4J[+ۛmPPہ0"sdZ Nhx=tnƲ(2 uvX7-a^1hWn7IzC &u$/yp8/wC\oX[H=$ʡṗyVA_lo@ aʱ^SE tU F^FKaYqˠ2=hyMYzMU5ʞvoH#:+Oc!XQ>by6eJ$%VܘD׻ީOS];w]6iDCZ9#dVQuO~O֑ 2ưxByER6t 쎘'8`YL܎X7]h.Cqa<КjGkzSE4+ H2489r]!D>zKy5N-RO{TUl҈Z/d0aBR a<3Ұm&/3-t%>ݴx$e 5!AmޚJel.du7pB_n||iMY;_w^Y+P fk=$3dk2j*A%6qªt8MxŞ> WH4uwB}.wNsd,eVe ѹ"45;tw t28 E-*/~ձV\9Z)-`󾓿~%En PhdEkL5]a,P?WHiaSgď~aGgYa i׌8v7QKZZg_9~X`` ˡO*mW^~aycR0Ʒ]2 Rq O]NMd˷wnaMPO8]I(Hdw*Mo7[|k7 #t;'ġ=.9H ӟ8V!ѤJxdp'8)"%Tz&}+n%=)hV$Ш( +LNaU{k9\'qaokHdK ZGJv#֘v"SF g-WNX{6q@pi.nac\I;Nk*"J$sF@CJ8:@ 웰rL<۞]qi4̶34ÃqoXE@yP8]tDM{8Øy޲Eʏ q~SZ8Y CE8 թݐ.IsR^l. kxr&pIr3bD5ȎVsVoZُv2>=2x'}m)1L$ku l9[4Q(L⌱^we42P<ݝ_s[G FяҝRCv".`;EHQ6)_K޲*uAD0R= ]%?ⓚx0ݱʌPw Y=,x:&T׷f:IsJ ugq?+9 ;-I^(B=O1vvyQv a0h`4O3a:ġolK-VЃ; 6\F endstream endobj 244 0 obj << /Length1 1481 /Length2 7069 /Length3 0 /Length 8052 /Filter /FlateDecode >> stream xڍWuT]$nP!A``ahiIEIACK[R]}γo 'Pa !( @顢@HHT@HHArCP\%$B۔(4!pE2’2BB!!H2j x(@!Jg/$^?n$pSjQm0 Ay+ ,#(!~*@x@Q}+j ~ 9BNFBh j$>@] As{3W"(w0 vP@y`/"@ǃPM]<R=١ rp~u)+ zUJO!p+H z:b'87m~b,hAԕdM!(0x8Zی CA?>`wtoD(, ڠ{(h3V BP ד%Zg8oTS3V4܊OPDH$~Τ Y?bvw?E?\!HH\%K?5` P ְ =詀7+"`SGSG+(,& $ zBlu(?p.AG =l6N-.z akD%`$E>m4[A8;!V-0A/۟P h( APM UB΀@a}% nRHo*UPmVp=_D|kakY8}~';O#+T.b]tK47R'/h'_k Vg=EIXS k"?"(@tK4D .!ėեUY:l1+j I(fk <"T)8\W}*17N?-M9vr94zXO=@~ɇ҆ BT2+r<_Ǫ\]H#- %ooҾUpпntY)!ST gj춞.قݘږ5nc7-O8@^+# ^Dwr3΋,ZGVX|3l꫁B14׀Sζu .JJn\TtR:LqY-6cpYXIrYdݗ'+T:3B\Xg ('[;%U3xznIޛbD)>} FPr)JMg/IݹsPW{x p6EW+z:z<"(d;iB˫\V]~Kp>uZgPԽ=^?PoB~^#da ! tEFMh$s8tp8e_檖.<,F:Osv}DQs1G>7_FŬpZf-DFOb "=fCÃ.#GR~ʷ`\5c3"p1u:a朴hT!˨hUv@ TJ$X +rrŸWm2vve>xl4Ztl"YАߊ,(ٽּ?"qLBݟ0I>ߨS^%O0}W[%lZ:h SF2u43+jBZ1^z{/+%n.,"Zع>aJ־<0j0I4õ2[Ys#QY"m6N=c:7PU@٘js.M\B]"ܜ&Tf<4g}0+^GFקɜWg,~׃!{5HE93.axbǬLOڳzgэG֭\|F=.: xV͑x^Ob<6_ )85vf Ƨ=rō/b"ʍ")+NGY #p]jv?=#w;tA>[W,:[j1t*J[N}N?p*u+!`!wk$B &/VLw1Ǥ&̣Ԏ)|xSd8EQ򤈈yw?)Q~l1wӫɵL]n(SVevXSt~ =%\> C꜀$GiB.'de̳Sn(6MO +|[oⱏYц\թ/!sfIit+[Hz|cwI4_*g:S|[Umة{*0(Xb4^fg|PU<jV -b: ?TEC~mNk}wVr# VakcX!Q̵qs$8n6`hUPL.YGeq0/ڎ3әF ͍3"Lx,#5inhW)c}yuöak(k8\$TX|~+?,W6>$y R0pRȝ[Iz< Iטb7L&)K0Ebg9ަE/K6-s98*z;I_\ؖϢž^Vx08ޑJAi$ZBMCǞ tP Ͼ'w/}XffeZh9yIRA^pU#hDSa5k#Mߗ9}>Nth`*뱭o`мV^ċ _lK>Q;-=,wO\&ʜvXx`bC|k 3H=u~Hl$y] ]HVf:K1 O=RKLCirw4 Hg(>9%/enE;W[oS7a YM󌺚 ڐl+)5u&Ma* 6=bXyɘŀr$慧ATޚ ccr-dF38Y7ޢ5/fne%AE7*s\Mw͜ nB~&O6~P .wAn{;g)s9j?Yh:<>9NؤyEx*x\~Quqo*82KlOxi:Ɓ9T9G)?FT~*?r'>8Dc*^,YYjVXkjF0lz\.iُ_P ڳ\)pqqLjOips6N oݏvƷ TKLoYùxO_LU^ %SݽCṃ\딟ME%#9s[}l95V*~eMTc{E~;u9=6k aJ_gSga$(Pr`4,Yмq1?Qzݹ5pqՉm@/SZ=Ђ7J)k|yTi^=&{3}c5a sg= C{O;-m=ahJO-M= y1,q`L^Pf.`ޣEܬŢQ~"FREFJ9Da/ވԄA񰆫Jq"f(鄴{c |YcԢٍR@;2.eUf of #t1@*\~||m '7)OY<:!酔w3Z^#Q45YFѶ:wKo6$|U rvNj˨s-l^K܏ȅ{ӈLw*q+,ϕ X kwaw.ҏ &>yffZ孶LqZ(pp2 ~C>f~̪YY=6-5JߣR)""_{#o[6%M\96Y~)ȄT./eC:QIn` ܛmϡy6mH(97M[Ҋeо_*V^܇X责I:W# &d(0<3SH;3a 4%D߰3#A0eWn(yCo0 YSn,}Q"^PY{lz}WE \TAW2_%3^*1^5~KMMY_pϸD66mkG^iP "KtpHTy50ZKm\_>5G%R4w&| 2v,y(FŷFQSsE{Oe?#IlUwDÿ".2ޓb#6fy<ƙvSO5ƏzyVGuF'Br;ZF&d\zkN_bl՘!+Px[Z%? ~zR&r`UNO746"VOw eck\ 6=:͂8EV`zF/̲)l@l U >ԻQfx́!s'{0U,Fjo|f"?IlS]Ҝ?:EFeX5aV*\:}ҍDVpdDs8Eufh ݬ]L[`O9%9{4D? endstream endobj 246 0 obj << /Length1 2659 /Length2 23344 /Length3 0 /Length 24842 /Filter /FlateDecode >> stream xڌT .LHKH! C7C tHtwt7HwwKg>ֽyގ QR6s0J8؃x*L&&V&&D 5+-1"Qg1,32fV33' ybnVfy=BN?_Ԧ4fnnNv@g+Sc{1hhjl Pu0<radtwwg0sapp[,*@ a)jV.UA@X`ke w{ڛUi9#oc o`ne (J1<@tc{_ƶ.`c7c+[c_$ibeE_aS7uڃ\'f 4ݓ;{̭5aȨno ,B-LLLܬaj+#/%/1oGG9 9 9}T!23̬LA=`1o ^@ =fӯe`o2JKiɾu""oz6&= ;8_|F27wp]-xLS?8hf-@zLLg_Qo$IKQYzc&+|3ߦVhfj c![;F+ +o-WueV@%_=x5K>-SLɿT@7ٯca;;{" Fof-="1v;8#(;Qo`8Q7083Q7b0JF`FlF\oE7"kQ((F*8oήF8oήku~#gl>_mR<;gcS md-gWE7:؂?6_;e;q20Č],.*[c?Gm~A?o .@p屁wih ,#?O? xS6@m!);2;|;.5jp0G;?fcGm\.=R% /hfb4lb_c ੺/tc`srJ~'"A? p ? xWn@p 8p$/ߩ5uu׋  h8?`h]r[)֝~{b[3{޹.UkᄁNMqB OއMp!?ƪLlC=!D Wy^ E+R6ƭ{GMOp̶N,c$}z4EI\RX=!<-)bw>Gy:k,Qw?KX\tp OPz%z-y4g %-ѣ1챤UX7tU Ϸ1oe&blW5`:*bU|3 U E[5:̭'k^ږ~N7Iͷ >=̴►aKeug mkofm^8^L'Y} JM[ (f<[+f+$`;#cڞ-i}ǝpQ-=Gd(~dο_$ lo㺤DkA=Td j]30S_Fbp8T.c57hTM5͑Gwbi1 y}sby]x~B؟~6T*RCEeg̰uA_䭪m6D&&m^[w#="6dv/r:"%@cj3 IyGxӽ7|?0U0XųHyPY{FA`CPvyspT!kw62hEbTsj(e$$ #zt"f)/|Nk澬 XdUV  ^r&b#g&]ry(1 JA,"r458˺2>BXbJʪ'|=qf}M(VNwHt o+Ok*zwLV K.e3Jݼ9Vq?v3RIYo?Mj2, tHzH~mE$"\F bQdH*V"'}ؿ/mYm= RPX|6 Ksu/eZqK MFӉ\2}pU;G3) ͺޙERh3jVн5~41TNW NUбZIDA*3ʽ}k;J9YM[@"p.y?e}c+yL`;[o|L9+ԪۄaefN 3mV_$zE>G`^a2eV= ޹)drEůkVt-\\%3DG]AzkBkjY&ɱmQԶ &e${? ?)3TJ74 q.6.fQi(^pe9<3r_ޜ;#e)KrrKY=S Y] APE>TUt 2iM[w=[K5? 0@ٞ/ xJeBtE0)%,#ѓB7ӣic,ZVQxA-Gu;S(DkI 6\CBBUQ/]{C`]|di/ p)QflߏHm +å뻓yK3^*V3=]>Cd;KZXO˹--䩪{Rvg 2_@Ft&"UcЏJl~RAX4ky%f0Ѵ1HYE/wnץHJtaoGSMnX8e<]ֹ0B[P_y`)ӡt7F%]zyUȹ90)Cu uH~ӳ#}$RmR/#QĆw{!գb7dݲPQD-SUqUv ŗ#c0 ޷uЄuh( [4^4b}o FXnL%mad1RlXSQG=$9CEh􆓴Me\K˗ >N];<}I߿m?BQ+leXH]d)u/R %4ڞaJ]ֺ%yBϻIQD͵C!{m DzR)m4ֳk abOZmJ -<40|rc@Q6v|a~QgaV #bн^'_='ϲt+FЌ&ۆſtw}cu!gc=X; uT.e>%*ɞVP2EJ+ʉҾMTOsjLH99/']No ?9ܪUմ|"[-Kza-8L> c!)7CnT9ẁȩ5eDjݝQWXH5 =5-cO~NHOhK%Te6{wv!&}RsDsX?NZp9TrNg%^0ҩ)X{]xhB|h$*1R/=OTʬ&dQĬĪ<&o)A2pY/'_5V;<+`[h6N3:ltw%x( 0;/GƉx$Nqv^T:JiYi7I5XF/2ըALٻ@ 禕f#Â?eU_=pݒb=<SipF<& zޗ{w3 !,i53k%PK8>/-.MBqВћeCv:^.>tU3/aR)z=s͏;[c0(Eoh=͚y7Mx9 }oXƭN=$EmXJL4Zݥ>-WM]SU!+|[Qe 訁,J5bOmeyHv[zGd@\֥ǗL+l&-ֈ17d{:E v_ovY3Ou[)|\X*{f|rXen\JX{KsZb]\>vV?_F9:9 rΆ:Q凜>>o|G@B{bxnuo{!UK~%clOuje5G<݂E'MEb2|!٤=ar]Y%^ L7FwȺY6R"d&SLľwHQD)&%Zگn,{>;1KR Fyﮨ6toWuo?6 EĶ,B4lͶgI5 n@,Zq}hȩ^,lE7}rl,U%|sFk4(%]21/Otٚ7%W,N|5[(Fٞzơlh.ۥY?^SO>C _wC ]_q 5IL;\z@S6<o 8&PWE cTp%mZHtˇTF/Kui-,I4`p>_}RI%ȼoT]& /x-lr }ftj/#SM)YaXk"CiIt)s&׊Jjp9%ykf/G+\|4 Tgڐ/ףndFf<ӓ-VW{c  $(.G˹.sS&]%hĻ iܗ{߬F5)&|{4uLKaK#+wˇ\&;ӍLlaPfe5˽>K4bكM (CM1VYs B- 3aRv"9)$|pQ |66V}W>_ùYH^(OU8|pF9n9OW$.-B)gpMf)9^s{%@f-u!uLkN%)-Ɨu?-OS^ (.Û|o+UP4.ȅ23Ņ͋N H+O ՠxHoM;F\Z-Bne G\Եe0I,oE5[ -<Z*1VI+:Y&`3_2*dh%gό2!V!-nm)*` CHeZ 䊉D/N`kM"GDuǾ_D\F7\Cr*"ǂCJ' GaZ u\vTtC,4j.6蝂6rʑIQ1~l63OoBDV^N =jʒ[Ivxr=dZUaט1.fӧ8ڊ9C;agM'82ZggOּpYrMkfa6ix1#}Ùy -jJ1SB~֥Aw=!moj rB#>\-c?g|Ey gi*±PߦKc Sѻ4u^lFk]= um*MiTg10m 80&'b7w ۓմP"^JҠ~ Ɇc3Yf{O%~4B\Lf-NF9$+}IZ0M(+پ#µP g+)땾宾47xDYStngbG7 tKRnϝC>(R&"Um?2| nΆ Su) T *"~PђKᏽ Q(_+Uun*ű=3i3<l|2Je}q$鯤C_ & ~Dho2ȋSS \J9$T(ʲ 0QHrIL+WfKsOq߱ ZDq6O.j&_o s`"+VF`Y~O$ x̱ҺKsgT$f|wkX+ݻ|{h<_|Ҭ :R‡$6<)rRA<_aꇎXZJ1DC'u& KO|)VX{V0r~1ddzR{hbuo P+Kf)[znKah K& ?3n@Ia(&['~MM]Xc$uD}6_yo2+HO2&CGr  h1 `B&@s]~TT #WD$hg܌BEn&m^o@C|ߒBh\_tdco w:6z>3\1F3Bmip>48fv,['sKB|߇l5AdiGWv5gmi,eʇZfYGF=bgEq:bJw~IƉ58Nkfu}Z-#̌^e\+z;'MTӋ"n, %$[:;p^G̾I[ylw<ݖIxV*b˨OG %0VuoS8ovZVWhr _znGzCFq z N]W+ /+bhCaBFۼJq",G o2|Yns@ ~}E,U&&:?2q ӲEF-叵ގ3B 7 _z--3ho%6*Z5:ZCtf(*.3~dtopёmu 4\e*aif<LJ8! Df H/{W+ Ɲ&d&>#횱bc~䋉8o ۧ&0&G;i8)KqSVڡ%$cn*Y`m%}uV㋮Ƒ64\ABb shSKY\JV{- VӖ)\q*KE$9?YDժcK\r^j=NY.⫋7vʴ{d8g >E919B^UϬE{;vӍrNq/HO7t,н ߈ MdW[}z]vl@<61!p$~\&T -<,lYhtap"VS?} [z]؞m%xBhqe厂\EY^VOBXOF ؞C[:qc]!g yQhL4b ^J6DJ!JEr>rPiVKLgʫXh#lHhQRNlA o.e,Wg^\WFG| ^7}(}Mʑ.^v ^“pÓTXEnM4EmPD$JDduGG{[c|1ýgs ~ezYM=}C4{571CDNJo)W3m?(* DaNhjcL4r$88cvn/0rۚ9أwػMY1S&T(#23Ƚ-3C}j" G3ᓋ:8%w]NEޘEE/e`$zߨ'kpƘ@d|=~|\}9u jJH]}'*q ooIQ/G|$9!;Vlj1olPnXߖ4XcK~l ?n~gӼg~t(42 U;t CI4|/[pO¬cTX q߿'MEtfL 7r\ȑobB<<#YQ&+ū(4Ċ|ι-AT+-uЪˡZ:šN> 1~' Mr'#yHպ{] l:\ePRfɾ뒢BlWs%]}!ͬ5pN)E*1fؽXRW.:ٺG*T:b5̀hd잂*"fFB6C2luDb^Z|gDCv.wV< -/o}n)D$ "Y,_NUeoF ҉CoƠwTQ]DB& waz&򭚞8͢rEFPk@[?d ->cQ0gކ7'!v+f&0v$U\ U<KHb|nv2؟@zħCNu2_gߒ'r⫑E`l`/$渎k} %ĘȫX&XCCm]x .#XЅf3X@;ľog)#a'GƏ*o,0@5m("E6,!,pЕcy_ ?rҊsjƏECw#whu[R`ڠ$93QvV.]cF('eKDG>>_4Y!C/|KKexq26#$&1qr񠘌ZUM`܎Y4Q'G?2Pbዂ>-?1O߉OXW!Z8'2Xm]a}ٝ q6 ôhUSհW +گ`8-أw&(< ?O&!ΠgY G U.wUjXW!.# (__żT@@l8AR%w^ע j6]ˋ1+0T!>^v ~aC,<0*"# [G=4ɢ$^$n<60r I;<"v$$4t6擴54"qW,$STa9Kv߼JPiNFG=w[))CL׏!՜D#a OpZbjI'7So~0Q%ctW;3##/5g8 "cÚ}Dt&[vGqߣ|mg#|?O(is[GǏ8Lvfz cBY&5] |%" U9d{ ^z>~ od˸2*`ݱbzN.J{vm*z+jJϻkHԱ# )6c߆ijI/싉_;$zVGnxyHCDT:뒴JGXG&YEltFb[c&ni^ iW=3 hDoKQ7_VlMvz$peZV኷sQhͲeRtdHs#8ycmI6g$yw״艝+~5CR Т䪈FOZ|#'t}Q E%n[N")? #͠P|9oT_(C_"Oŋ]PdU]6% =k+Vn`fMBdoG⭳ Ro48 ΃T=uoVacE3,OQM){ǔfQsWE&-DZFks./d𦆮 5vd!08_׽WV ͩU}.^e Q 0v7 RN Ɗ)'kإ'i&ɓ%] Cm75+8@I{`vabA$*nX) Lƅ\[՝uv?,|l,5aSfFdg,JW n>>JVרBuz۾%3캦Q1]fDQת,c[%kj28|;c^%9T#aXN&i8N6rr]^l~=lo)*E5 [ f''iU6 [j6&̑A :PX$sDUq, c^uoR5Rut{WeȗjAvC dZQ L1gJ%O? ^5;g.r0pND_L@km>18Zg?*ae"5Uay%oY\%ϳVw50a}Te!\EBX_9'Y?EoLyqPMDž6Fl~Иō\II6KKJ<>P1Q)c[10 T`Av7^$樍BYb&I}9ܛOwð si_[3"1})C=jwz&|*%Dc~v1Dr+Z]63}XȀ8I[f}RKSۇu/oFu*crfg!ԭ0Ai ^)U9A42&UtGSrJ32U3Ň{`)tay-ERM>;nkf.`Mm|YiV(EeCrH+[+Xa1sʬ]؀/ [goNfY5Ы8gmwC-{~溺G[Y>GQM|\-NS\xڌR>{ެC8LL)y.տIO@/LOwo$|wlQ)IˌE6rSLeC;f 1dܥÃݍ3LSkcTGɞч ._nsB2REfKnw]! &cZOM -X_hX) *}N<>kT[P=͓u5}2}vD([++Cx[R£u$ac'Xߑ/qHQQ#] jśȆ^kg˯&:G>%J? >& 5id" :[mj?D&9knωdֻM 2iEWn2HQRT B<x[q5Ǹ kiT#Ecn\cAaEO%A4#L=|зiZlt!/V$S!6CboP 9I %Dn?z I}fGAh Y?5KIIP'J%cva^UŸP $FXkEҁywyݵf{4 vڠlT${ыߔTfv틘n~Ņ;!XQI/T$t|Pp0}5L^&u/h5n%5mEWbN"OF;aqoêp P|%9Md r@9Ǿ}z\qQԟ- mC¾Z @e᪪K% ) f?S<,[$,WȞztM[ƌNW?M +R}[W K:7io ># RflJ6Q׋kd:6 42Vt,[Q*'N?R4̾PSV4(*I`#RTH8%nv Ώ /fƓm(+oSD]%K XnD>a:C} uGOت>\\;D=DKbjTm -BdH3:項޹~MÈ?{|VD%+)m/cڬu,0Asdևjф@iٍh\7\N^XkkJ=5{x= P rq;TKP1`|u{QbS_"|4WuQ[f˂2ά.I Gȵnvs-4}F }Ǧi6u|o*Sb U1p5 춫U?'zKV_2P}<'&x7vն0mYl @ZQ܄,55P'T:xdapj@)444 61䣔 z[~cT6a𡅢nQytkX,p~Ak"9ƙuSoY,z09ok18s^ߩN2%ni?%A>;5k޸y- !`w̛tP y?D@_aJme'D#h.{ga |Q eoa$Eisx\;E囘%◻'aS9\r@/ŔQZy͍L܍`^6 v<]8TV&ⓏH`UmJ">d~+4^Ibd ~v}"1 ZtطdF00~(7Df6 wWnC3CFH8Ï9V4]4pF4++crLoNx̣) 82AsBl72=KH嗀{tHXAd{f$wl-f( C$i}V/0|[4AUs FByј,]y9mK6$uI(b \CpOY/q/]7DNrffX2+ DE-F4jN|yuveZ$g{DT(B_@p62"c0muXB|̫ g w}Lo@̘X3˹xxv]XIn--B)OXo?D*> H|3Rn5zs?KRg'@Mo>:WTW5؆T%z`vH:nl()nwDtg[L|2Uʖ3KAnFc-3Xxm \Lj΀3IɛE,DGPw}V[_-e?}PDKxF^ZyFlĶgV<0@Σu|A۬MI8rځߧ]9yԣ!#C7`j){™+ j{ 4;$ULFz;CH%?-&GD1e>Ɨî]V_UO8%%o unt4m*{-9['B|ɖȉ#Q#^cYɠ;8=zBtľv̻a9˻=;ӫ\8f'r.~ڗj|BQz b!MRP<=( qd&ld+ ORnqz-S-p6 "^n&|z%mǟ!U;&1HL'!i.Ƒ1dkw4-By֪YRft9}&j]A4 AcuX5j~a@Fd}8~wPid 6:nk9SÝ(JtIӒDt ->!ppa&bۍ6D!otKX21tS8G.~qyQVz|š\9_jo|&3Θ=C r6i p ^o!q3c.KaFjhm֯CSǯj@Kd#xpRKn6 -=Z%rCg.ƐA lQ1Y3P߆m,k,;@f2i0M-;XtAajk5W9 0;!+`hC|"sr%6O/6Bh׊6h@͡x?h*`+pkdu ! Э`|uHͿ}=:ɺmx^w=xS9j.\&ݠ YzN><&͞HskW'Rn, q*iHOG:s.3;j-86yT9i&m&?gua]ͼ4{nGĔ~m,10c! &wQ(,&|<͗lj@A7bЀ3&z\@3Ԟħx/[uy7_~P[D(M. j:)9y a+19Yԍy#}ۼ#*<-*q~-^J$y$<(fq%GTDׅB7Ȅ\< esuW13;_Z쌝g6)G y¡HG]9O<$8crmcMϨchQFSΚ΋،845{& #ɍEh;G7VDc"fH)p U\GYV}0F @GIM3}MOdǼ3(3oL[>W׺5ith¹ n+du8*@R_-ذ%/X}Ӄ3Np-K/Ñi_Hy2t̸C⫓~k5K^jз{ùX*)U|cg &!NhRs{eV݊ |⚻J\xuy>ь/k~2h+4f"W9t"'S$ΡSVlRXIq&j[g}|{}5;3T6cIWqsY["GҒjI!*;[F\3Z ^+[gP oȁt:;A`WbA>^%8gb 8Pr{Sؐyi 覐X=6e'bzP̓!um-9!i!-Kڎ\RMp)iq"^!d&ho7Fj{}1i4ܓ`tԀ[ciR~9mmKwdE72OC|̺ #n?Mx:0`0dVoGZ@-X8<|;i{Uqv$Pu庖PZO|P FiZQ AE`U<:s$-OZ$٤Q+PBݣLT ÌiÊ׊ne Ȉ e ZJ`!=EST/ev&MEɒc|O%pd&D+y#e@u_nϦR 6ŎE?#~ uMA -g0l6ۛ`>?F"}2*=&":qW IBFzQCd]Euk:Ь._߹/d+4h@ J7*v+ p|RG]E[tY08?.Ln GDt 5}_ł;~e |B<&ԢqzWo *ƞ~SkеX:_H#\qTU}1Άqbyi 1>TFziHDЬo%oҗmKT3boޣʼn{6965zܽ崃UCmd!gʚWv3+恲9bϣP Wۀ puJs w"Yyʶbڗzfن!.8ȁRqt_0Buc}wmBGkT'gJ4kbP*,;8m%MvͤL!׾.icbj\rGUX=}ݯ>FaK^Bgdx[ؿ`= jnWr~!FB;+1//ϫNC4F$h=y+G-hFET3&sݰ^'wx `H$Mi6ߢߐP~8lb>3ư-ۺCKjp8gZ ہ' _ő;&t'c>&joq~/C0q LQz3:}O T5W̲rfjm$ޒlKՑ${t \ ]Qfcӣ KY+[H~(@)t!T H=LShd-.#Vɥ/׎ѠD heȽPu^oVir V8~4q6ەI=5eGYɴs?.ɵ A7kR< jFve}EߥU-ne+Z炈8z ,_rXF $cKgbx,(*$򦁬Ȋ+#qjY*=L\XwNh p59d95C<F[l]>Ue4\u6'#B@ńӑ, uT zQ  jMѦVEXg _\EEDo}3weh2&JCz#bÑK Gο&ZqnvǶO?g$еJYC >@/-i҅{œJp|a|\Qe4 3AV̨}&K{5(Lr:'( 42DAV=zz.G+#,svG$9(kᖻ,vpxbU oXg}jA8YW5q=n c,zbN 9 d/\.3-J(NLf HYqzqQ0%I| ~1Ӝu=bS``0QSpxF;$>Tyv8Z&#YeۻZ ~2' 5"Q?ɛI޴\>FC&Jd`ki,ǡ>N\̔L`A3RqktVpΦѿcev̈́mz܆v~dcB% czdCҰB*>J؂Y  k|RS{n?*mJDz%rX ~n4nS-8#?0)DQ}4^n ։ЭN Qm`Ww?N\=i;T-C`HR|@٧MG K4(P7+׾}UD^itSMҮڡG'nm:~XL\sT/rCCQ)sE͕q钳@DLd%S7 D3Ֆ*WQׯmNfj&L6:G6"'8JvkpdBhehtΟ2^>,DRh*΅*> stream xڍP-܃C.A;w 4H74 Npw'K@xdf{Ut׶s>ѨiIX@AP3;@JYɍNGveFPпR0M ]\<.>!.~!NN7'P@lPf(B! 't:) leT??@& ? { 4͜AOfvM( rBnnnfNP(+ l 9` *f?'cGhYkB-`  A"\  8@SA IV l\\+w"0`3 j`C`;@UVݙ`M4s>ś̟tnP= xN@ى l{DiNYb!A' OBn%ba{ m Ʉ |9@@k<@8~&r:,-AO_^Nf 3o#t.. 0Y!d2,O 9'yY@!v_me7*,NORby` y9>E W*@,?}:43LΥ}-ƍ8y9OGgiu6yExҬO[_.ϝUY]׫l+$ vYO%C@jP'W?>NOzZ.)B-~o7/ 3@|7//i-@h:?XBao!P8FSHipFr>=t>Mx[Z_6_PaXN_)fZ{zOTWS5ؿS5}it S9? I{`O/t< ;0   wc"2EtFMb \]I$ ]ޒa_~:lm@ mKTo}o1ӎ>xD}?%N-b+|"]Z>[{}hn5Ih(i<(lϘOq/sY}y ֹcng1Pd-)Gm0{${l8㩼^rc^_B%oژȢ?zCfeXH:v vp&שb.L9`Xҹi+c7*MxA2s N9/??a{n9w!Dx|o(|ǿO3 hN`*GP셛%Vrd#%pn"Z.נ p78Qs*'{fd5SȒps)k\ /UMvV d\jz?7_YbqF yLL;cVpKe`9kN|=~ Fz:T.7jWA8>I/$v;G`/SO Ϡo)W! Yz Ƽ?Jt& j=΂ӑ[qɄXb V%fMue(yI,AQݫ1z vǏ}4[ Vw޷Ӿ#){ )lIv7s5/s!3%܎}_/P]R̎aZj؇^AN+qM{IE#G匀~ .!m=CA҄£;hͲ"&EkGb4v V{KIZ&ofdT|]BW~|-G]\0K]Z.H䛴NC6D^XkGEm}iסMǤ3؂m6WE/BabLSj eh]BGF`~4__CHdJ,5jqP*w Ca} c8+ G8W "?cԦٓ [,Icz>!ubxroY-fE:|2άCL+D@r*WLż; (ږ %T\:2n,ta藉۾\rqhxK}pnzNMc곀y[`&l&NeoZly!sjiWu9` X'1"[ϥ$YS>RqWi 11';E|7J/ .,wJ)Ħm{8rQQF"HCSX>76Ev<{> 4@r*]z*ɯPޚfSuATX5@`6 Gh+mxSz& . !R`?-RuswN}Q_0h^B,C   1)i(uɻPn-24ZAPw8.c΋JCZ iY[^D*7A7sM6~ITϸtn{BR1sT ,l)^ OD/;H|U)*6DxE2"4=.fQ,: \*HOH *O/ #FXEI;~AF{^,V cs𰟆r3ap=B3^K| e {#%MÕ8ϛ/PO΁6ӶU]rP{l,CFR S|7ş 7̾}f3YW uyv\T# hY]|Az~UK?Fz/ 001_UTB|/#7Q wWmF[U. XG76v!<94'Ch0>KM/-Y=V[;^u䵯R)N ލhpٳ[,jvPעt"}p.D|r)W# ˣt9o+DԤ|Mm. 0_jo:9-{8"~Rgdh47ce]ą^3&.(3HD,iJQ)ܽ PtiatK)2OԌ&ܓrvU߈F^[Vmq~'C( #&^G~=ؿ6t(wFWgË65Hwh_L55k'T։jmw<}W]_3 `\q80^%r*[y'DKt8Hr~G;6, /͔a͑Ć_C HAk{jS6&DB!q xMG X78OayGOpD3U AkיV)!"^!S&8Cic\t;<3Ft- >U- djU1(džݞ'scCŶ%-fRj#_6`|Knہ.m6f] Q}sL- `@cHfy"R| dj n@fmQ&lΛ3^:9oAZeqR0k|YE%}٤qגl+ws^lQM瀜2ܴ|t3SQoǭpTՍ/NǾVd0S[fJyT}]z ;VcS1MCMs}e]y@ڀm|-D=Eq焈%^~2ӍJ"{pVd  No̎<"M|-pU-f'QA=J% ; n p|h2 8y_ TT)>}&!*?yMw2є( jH˫vRU䬘3? [:_UPE%?)*ap Cų.wUFgc7e:rND7%9 ޻jpXp K u[mU_ !$nT]Uom܁Yi:=j xN󿜝d\h tFM2]ˣWY-rX 2`aiBlp@ݓ ֜SL"lnf6#>𢊷Ҟo~ݬ|+˰*` f [QЮ0h|1t{NsFFcV\) I8)2Kb Wo$yBn0xMU]|ιאT5zؚbСs5<uKųiC`B}n af)=w`S{M!ы,Բg¹5Gs} J">·"bV#crm6m*U G]]"ّkY.jId8d_)tT)׮g!T|QTf UD *|R \ֆѺq-#ub]tSܦ*q1Slc5~mt.pqnR=b8{*j(ۡvva ٖ㫟ŽXsEĖcgMI9=*?5?]3]v6El26rTv;c`~y&p뒊tw*sRu(wfc}f">Մ (9ґw2Wzp<8:VϿg(AmXxqfDyDO\.)ucCU?$ L X둅iBmHN*)n'v̔Unᱍz*]OAն~ŧۑ3*-@XE$z\DĪU[fAvh(}zsZT2?Y獥vgES6"m;C{XU4-/fCL89?C6?\};B{u#ތ3㇚mh4ԵcbE8.9k&Ӵd'ֲֵacZAmf& !32T⒏/ѹe1i]G BSXQ'e-_$HñUPmMmz72+hw㱲3oC_|m,n"%~V\X&$N56Q4½< d O=šH]  |Y5:k|7F11~Wy_a z}ͨ%8)(.~բae5uwq[g*s77=&lvv yMUal Q]1tWNH>r$8 i+k8:&8. Lj"`O`+lV!DN7 prv".Rx1׫;ߨD1WdžFа@6Rs،U\4盓 n|UeTO$1L3EB$6"]==&"H"(͍I\AeM'z*D^\>>B 8CE8kD<2EFйB?^&~2&p :~?م;eXs)zҘܳ5(UM jjl݈kJY20 aW)XR "ʯ̐q@xE!ݣ /A`$#y7q3H! +t+BXs-b~ITot3uL$nJ"PZ㏗u=ԤA.^^t",&Z-\49SFa /EAUwY)럢:F+t k:L}W?٨;9 |}Gt /?s0Wh~?L}ۣ }HH} D+% aX%bsHZԉٴ{|ES2:RmZ JQ 9z$OY)"` ?]e?QM^Ht."!7FHKNc"In/M+,,}!7Uo Ǭ,̦5 ON~7NSSοJuN֗Ƹ_TSh7ryB}#zxA37lq#/2.w V`^?j_ug\c<1ooJ tHGW۔7Iz7t9wB[0$enؾ,pnrIg/<EV ڛ'l*yhEUf A\: ecXg*D:U tEpS|eN<|!P*@eif{ 34Ix5L㋓b/K&=K^yb3&*59VK5|oe(cn3syb>ާײGBX))vأ=H_^~r3v0ZKqZ vH"]"4"2yu! 63t˹$ uiu4.pע9Lբ?h>rm`,7 y/o-;{^5\S m|q+V4\4~A!Z!cD]9#aQih]JVfpe3M] y5Y;G旻n)EH6XDn71rqX/hoEbid @$5O ^o}r]fW=ߍXS-luz]|\˩*9mdTL}8EiLǒj6;^9RzExVj`QfK2l'+ES%OqEKtl!Ɉs4D$Ը  у٨%3!~/"xXѕ[@LOBZmnd85;č:rGIV'.{UY舌u`Zq]h(.%{akiXɼUqSgGsh$ض]D黅uИgo3y- =ݻ'06lџs\@W{ endstream endobj 250 0 obj << /Length1 2434 /Length2 15173 /Length3 0 /Length 16599 /Filter /FlateDecode >> stream xڍctjlƶ5m۶l4icmt{weJREaS{c  #3/@TNEVŮ@IjbAT:9[KF hDҮ66 '/ /33翂N1#7KS#@@)jdin߯.¶@'K#;bob t4,\\xl-],@g;m-(T\܍h Rr3:@*R² S #?ې_F&&Fvv3K @ABÅ`dg[ofdicd +x#2t6qtpqft%o3Bۙ\~'f4Uޓ[ٻyfvfS1uu`RttJG DBC38A:&Lz:b&vwRZA܀'WXX&.c 2o 'K3hY̿3S{;?5飄(?Ix32X,\NNR4O R3/P?@=y_[h̻.3 5쿭_4IZxG4®.u-r@SKW˕r19hx9&[:KXzM-]L,jhlXk&֠s οX@*Wq;{; 0rr2D` +@hgR2;!n-'I7o `LbI `LRȊ"(AV VT Pjȃ? dx 9XAO:?(\Ș WqL ?E]A_ h5@1fFNt?C&^@IhY h/O̜m~O>NJtbys5}>$2dt dvOYC߶vte4T3 z͙ * _2 꿪rĝA'*:9[(?.#OڠEgrqȆ럁v6ww@ r=L B{d wskL\@vY{ hhobX/Lΰ?6ȩvJŽk1 k]A^xǝ+8f!P) @ n#!A fy?17=XsX^R@tC%۟QQ^h=ί I?%^o=bVAҽ3?[0k1 D9>"4^hUpL/*>/" GNĥ9 :R&&x>y'.05O»aoxZj!yUq-sN2crvܐ|*_>NXEFԔdpGMgA3Bʈ UiCs ="XN14Mؑ"wKG.JЬUAgXӔ ]bL?^p g $4aeC"_s5(hؖG-;,H_$};*i<jMҫ~B~2Y7]L@[JBM=§y"/Pf, 󇈴(;˜lg"aǦ Ta꜈/O(XmH[4ERz'h&}jwLzs_(qUMmGd)2zzQ_/HGܕ1`oycq\v;%%8 7”{Cr׶=1}ʫMKIOT&'J!;0y ƺ]#cզG-ƃ^ӼnנsP`}W>h%;C4 s0z8((ɴ<6Rۭ/ (jpfT/,.n| ;00<$z|/ iRIa/GT Vσg+Pc'#9q}ϛfE&k(1B! fsyH9ے``Y ^7%3iQ3:" %y JbݳJpŴQ6_. 0/е@MPa^uu-|@h!Nnu܆,MxOIɸOFs>"mZh%vqɔ+0uNjO6:z,hn5=;fgW;q$ҰF-~)22cU~c5eUt/9c][LvÈ5Y&f#QzٺlZT 8U-)/'l:`YxMh2^kqey"oJTOCo+K)"nX[ISE{ ꯉBn./ d.YXmrV;l)_V B7ѓw+@))_{ḍF,HݧP|Oȳvֵk sg40gȕVB4MOcEfM9Qy1lsb 冀Pv(z*dxGIh0Sl0ۨB>膛|m"s7L:?.U}_t^z@i$: !ɔު4"="ƹ2w֘\:F驸Л,'&d}u67i囧+wLT§2sU-4)wZWd;d*Ў{o&ՇYNUC5>vm CKAFlMYw (?/ǞM3!w%IOTuC4[,yEX:RWuHX'H6Ş. yթbJ1ӸB.4=$o0ja]% Jx첒 bz`9+["DaMAU{d$gX ݭ~EbxKI>ksWc؄|aJkE-V8Qż{ŌУb 4j|_B4l*A[#qrFc(A78=gfYLJNz?A' [6UJ}2]t# Іp^o4qt.3w^rDs$qx)~4V.}'_5/XgI72xY$B-w`o .-&:x2KڞX8!Vvt'@Xa/ɂ37E)[0n+`N 8J$FDS9OG[s 1饐|rwU5}c?}# 齮FtW$3PjQ1G's,{ ,Y~Ixl=ר@eONǨ] w!Bkw!!ޱ}- S[8Ӿ{Q=%ϓE)#lvؘzx\nK. ڮjj@?űE*yƇlZ]NZ:\TF1JFy@xRM1},Ulba6V~]U{Bs9Viߤb\P+s " j7J*| bH\(lXf:?ڰMo&6, 7{їDB}C ?5m[q-U}磫Q][fwgE+~z;*pBt~s}#eRvBg *]V빝r0 x:\y:Oy;@ŵoR|s Iq]W)׈xdRm^'E+DCi{n5c;>Rex&e C;}UT(;0]4[̐6,6Sǥq\څ;ήloC.:ۿI \*^";@-֥ռq W~B(D9m[FHWxگ$M 0kkszkj*4s\P8OЅTrI:ZuLrenp>BN#p}qͬL"nhurSz q]ei U`Onp32VGK <9q?Sjy*Ô)àvrT[V1^+W"ml3L$"Q9PM0]B9I]L(|iQ.o*Z9;F0Mk\,w]~mzJMKʳ  S{,-ݶwHq66g^nkHMS-E~;{p!B8WM58 ˦1 ːռW,5ZAi y>/kK0FM w\xd0;]F2Y"{$aOBݸO<2c,7t@0IVi7rLEO"r1~a{X#ېnk_ }˵^a0g+ⓓa&rlɯ/d;RXa3xiGfun+M+[R2gy3D\pK! e&Z܈w.z{C_z.Q( 5L^yyoW?3{%}(}J AnOKXsN[4꾑ך آ4۳J=#ܾ5l߹Nռ<lTAΪ8^=Z9Ly .Wɀ#%.GMsCA #d1'YJsT  OOyNE=BTloNH2=Y۶/5{隻sUeyO} hԧJbDd_AXqf*J>o+ٸ_;%-2 "8\uJ4蓡˽K܌3Nl|: { Ձgl%ߞ<.Em? S 0wNVr*nfi7S S!ܶ-y˙~oW[ǂS {~Ůl^C^riB% ֔`O%B#Vi&i2GքxsKEġ-m8pGQm<*X`?J <`7Őσ 9'J;Sb2*"2w-azn:{3DCD{^RJ}aQ#u8leKyc H^75%ĪC'K9\i\=P၎p@JNG䙌=:".G qGrֻ=w6 NDo:&vJ/_u<'(whbg-8)}y?ٽ&BF߂qN"jJK'BO!f,?nE{Ep Ix(%_sd~YwOa0Ugύ-2eŵG:QM,AКn5e5nj<ΙM^n1J`ux-~͙[,OR)$!Z4K}ήw#^G 8mމ3,xao}Ϩ ȷ*{ItlMJIx U*ӿᑞ*DWo!!~;j6 F(ZpbY=R"k{]WLvg*4E+x^0Rti 'e!ˮLj g!RJa&T^5u_xʤ Ȝ:6 H6]a ͧ跶nzgןtn4J=23rDK*E5"w>heM݀{a-r&&5-jY3zwʙ#X, IqFڬ8B+ϩ󤥔T{ۅyﱏiugԮw-T"t}0c;`nUU 1$ri{TfPJ#g6dvQ<aJ0%#t5۩7M1_}c%&-N;WJNd%8օ@'j}#~җCϷª.g؛9,w͢Q Q[.1??srA\:.W bC,2u:闙Fe=S8>GMf[M[o6*dc_z쩞-g:Dt䉢q? 0c^>E〹$!7OW}XkW̋ bHm/|°GpAW=SUˍ^HFҲ^lx eK`}wJ_l#IW}&u)#Q};"7Ԉ !3*w~oe<$ŒkLԢZ:0q\\8P!,ڴmv)Gj 4\WXV(w ngr]#mՁ,5}Mn5͢3 GMlUQسx硌p]fdNamJ?DXu oBR&m.,K܅BXn[[Wqpb)xCI;7}:3V 8,mp=CE4GI8 Zx.D[=_sPTKǣgTc)#7?V&X^Kogϧ˲yIh>Τ>IJ\'{y "\A˼wK=@913A/&Mǹ750HUן =ya"'tnxJ(gیRv9dtܝE4|]7ZvI` #]P 4+e*cvx'gH^rMH8;r,~<]P7QF,|u=h.zvX=q8,Q;n4N}0.>N (ilU!Pq 5s/׵FS~lMjV r5ajN\aUdow gcc >~n[Bvmp ON(m]x*zWSMt~/3 cF~C`8u{Yj)HP VOu{]TҚ]A;\t aN뢪jNmvk&G l@NbUoR,O04![B-W'2nGPQA/l~O2U+st~bdzo%%RͬމKd s1?h[+Nßfo }N/V_7@4^N_ES%{Y}DyZMWOWNWɆ6EڟjS.=Bz&F-q{_&~fA5޷_&1a|E#*8'"lr:W*F\>:5窓rRk [ft4YTlۑspb1yKuNA8iW\ OR|W}X&SW q͙ kb2xvSmٷEoDh&l*$Yk˪hM 6CNカ0<\ʼn'n,HŐm7'a!D{%ҫ9g$9}8VlIJO}{U|A[щs UdzSSSL@@w5KD9+d)&G,k><ꏄNd78p F\p`m-_Ve[&B$@ٓA$pŖɷh5N]$!Keq 1RY+ˎq%JDVg\-IŶ*zNn ec̠dxf&xx4[sR~--mKu6e$ #Ej0^Z<nLPTn_*|fs F'NzEV5Dmɫ D IJ.\G }Ulk5rM9w%yH!~!*N3x z}c~sⶺug&/mM9EPlz˄]kZm ~ynpPny//ejG^%涩jIwA#1ofjD}A0MJRBaWU-gǮ umCvdLU Tlm*-/ֈ{<<9 7 oJւ Rݾՠ(#m:D<ŏ=ؚ)R(]/r|dM}3 A{^uSJwt d.|iFSDo}R5]"K׻ɚi.'XTTs"?xOt]HKc!JQoU3RUl~/ѧI_ 1yiM;} tڪ"~[q(ʠ?^"Xs=UMvk^V`eVy@Z$&cٶwI՘`ı~s+~aИ3<;'$VӺ$iyObмȽ}g<4?:ە(\v_^U2V<#FXa]qݘ *>1 QvQnLpVE`ے$ZUo-~ad͘l7SBi!w MUym΍_IO<{}g ð) >QWS)5ψ@DrL/?qD(#39f )B`d֯4d*~SʃJWBD: JJڎ~SJ ގydžZܖb-AC%^6j `- j^LO5xGsMCfbNdFYJ㡔[i*3:F_3{j6\ ivޤXYn#fex#]>(z=UvP]ޒO:j2'DW"P8]ju`oj!,t:lU S*5gNRHs1sts*"~aouTfTJd]D)[/}IP V7~꘩Amnbc䭜2Y Zwԋ'_6[`bf9Z0Y.1 [Wfaw!JR&c>A'0ՑQٌjjkD_w`l_o_HLֆ!xĩ~o I8xp~` }9& 㧃UI0R2yLD> {<'GK4J4, }163.<\uxMlȒ ;gLD_&EGq9{&W#J0T DJ>3y_׃*lE2F/]b؞\dØOSҁVbw'k?n.*`mWՂFծ`j7#4K\A%|M7k6Fi \=e9~p4ߋQɳr!R{s<.U*•& XQ*^l*5?ʳQ`Ip_G#Z n_is.;S.g~qTGvކ?A* T*fu֯`j}/AZ+P~uס@niyl"9 f.N][TF" ٸK%`}NtWQd2QkkM Lrd8tf<+iP*2X׌^Zk'W%V4 =kSOm&HCo‹aXg[efGlq>7Hu T=} nJvol c ȣ_ QiN<-v[rNR $3AK|I*Mq(vԺ_MQ= W""3ɂ 6#}"BN-YteꍓLW8Y0>T@b ŽszlYnSR,ٽ1DxIAu9I(,7w',Aq[8%tV]!}ԴP}KWɨ":VkєFABF ҕ0٘4LCKnfšcI~T268jxVl@ɎAĶk<[&| ,.óF瞼zތ#/ s,_&.W -^:ȶ:RLŮ-aTI'RadxbVnCv樼I> wi[;Q)R!(b|RXyҲ;T{;~3<|ʜxD"M~WlӋ&|VµF_$߶͉U@'-UNSM,F9311[hBkg>xRIuDTD#fڋ7 f(ݭM">LxFKb3N,9%?U6Ei=v w@t|BCv_%4%OIs$N$D&&bìJN~ëȴoUb0, IxFw'$ '&_/n '`# LҲ;?Л.rfpprօh}PfghÞєSf-GT+rCaLDT!2ǃe K{H٥hTՌgeECtW,MRq @\0-x6nD_%Rrok>q O̮}&`Jr$F %}б9$?.#Y4MK'}MkB zSXSNxeI '7`Ð5 0)84h0S x_R=ޥ,%oLx//:B}λwipi=tjN?`:E6g{Ԓ?r] gkA7uvS@hnn{H%lF݊pZ{"QC =3w}ZGtȉL}ms)>Ϛ˴Ш@{F(J)_K[03ԖvƜ9BI-'a_yQ@4^ut 'w*ܻpPmCsLh@^ױdlT/ߎH})G>UՃM <mǧwwhˊ^Lo :hB>~ǿ!snO3J4x4Ģ:aP0í^9yMH& ˌR v*GCwe wwAﭺ槳5 ٢A˨2Y vib!Y-fU?̴gfJVbrQ'|"=alC.PD#~VtU|-f)/SvRi?8$X+ZqOD OUO*FDQN^y|\2$;t/ Exu'--EXq?@GeD |8ADngVsX\CL3P| SSqVهu%υƒw8g6VhK>'x~Y_3(ECmi{B%'*ꀟj!@!BLl/ZT&z2嶜~ q%i\Y%Ēb7@YSj|1 0Y-~-3(a=0kniğw;>:K0[*bgR3SnȭiN_lW!oڇ0fr6.xfrR/ܴ#05 ~TU-w`vtT u*v_$f;1hf:6Y'7hA:wJOz+iTh؇0>Z@4K4?^0x}9mݧ$pTi-KӅBL( ͵G5 ra 1}NRX,Z} 0t%qr2|ً~=\a2%&`x7=n~9#B Ps@"0 :kJ^Z]"66T װN(E N@EfVI1U٤OxB۴tn$B:I[ ?WdspaNjt3,t܄A,p!|ro3tց+`^fR1?w0k\Z4TI u|܊e+lGG#ly}g@1Ddˏj:|X &(SNol{UNJ1x=g9^:Hv5kg::>u9=Hت  DoX <1kB[Mq\jq{p5͊)!~OIHG GXSd⍗%ޔDzјY͍B̬uŇ쩥|wA&wӜOz `%OJW]nٛ26C-|x`Xivt)XZW5؈ãU}U鰄ـ@q-T3F<'}eF9_k% B.9Wm#ɩ]ݟ`I⪹]鰟gm$F4D=:_,vts1fN_FMj{.oa!?J5+{r>%v Xh.^SwEFkCd,aI䷕M~503ˎ;oWfo`FyDt V:1JVjf,utD$a:eAz0mm@2ćscƽ> bS&hOXV;@P'w/|2<FN, 2b YD^<ң9&ԏ(\I8IZq36}m}"s {f> stream xڌP["5al`-@pw]/Ow^սE\sENJ/lfosgf`ʫI33XX@.65N {;X:]eb.vW3+ C{' :Ó;x:,,]@eJ `;@25Xm3TMA@ Ag`l`d!@MpXT@'7/c[࿩1,A+T]܍w hjgtgJvm@ws olljjo`l lE 9:_6n cwn V37?gS'33/yo-@N@{2pAvf0su`T9m.#ؙX@GԒj)svẃཝ݀'W?f S d'h7~?'@}LK}l<ĥ5$hMJ{7=+; |8JƠ_i;s{?%{ Ԁ`>@՟Acbg2}aJ>d o.WЁ2dz9e份OTLUIysw/.wcU,Z6! E7I7ᄿxPnt}VNY[Y)/п'1s\MGnd&@9%g6n, YI{yn,*)D'㎿JXn բZKzQG91Jӧc@"BqInP>Vc%c0z"1X)Pc`Xdx|oDn11c*}Y)n~se7EJMQ4|J3 |mp,L-"jsQnT+ ay.2Dӌ_MyuEˡ妖0I>JDɌi;[S''z%i^ )ATd 9QO9sTT^X V|M}z/S^>gH1Z9/x4pp|# uݚOklW7j ӔF'MfAYX([dø(ls\ Utdo{zʸQ=Isݯ/fJ@yt i2 98ybUPHYZnCbiwa 8^yGTG݊\޳@~jZڑ z_j!گ(Ld0À96g``sq,HUH4cE!3"i[;߫5yB ߀i3\fѹ,Y,ץ;!,ܳiqAFqz˱Pʘ4嫊!ȧOvhG)ʢDH.ea)`J@Mi#4n;Xs7}"ط'1˧C]ُi9 O D"3&G1qezQ" Tٖ7UMz_UXqFW&cÕ'S5azi_EW!j4(/W oroJ1,i}tP}h(Ehe, b\Kh-5 ,J厗]_>\zq 4z>Q~g[}t=NtY3zyȩB9eI3kFX^?|^kOCS>cN]s*h L`^P&1FqqhȺTUh ?>L5ZRdS0KU3^Pa=Ǚ"!8zZR۩/l!pJn{;W%ϱG\/S0.kBS5(>6>hh T,J|p[vwus6zK<)[ٔ>΁!X 1d" ړxD=rrqIa}?S{ѷ*8b34C3- ĸT5 o[L KO}0J`A4%>^w¸GNɬ 4..Z*rDyP ǁce"sl>Ď+٢[Fmv_tLG[Tʝaəd7φv:bOL 2D#锰\s#| 'bF_vm(&VV>6Xey]eԤOO+fZj mn6A@+-``bE߭Sr17hhV*Pg͘x/|lܺ^ix? pV UF[\BU U׽:n,B 5vtq4y.դIwL( rte׮@e5[6ܡ*8LjP5s|^"ߐsd48b2])X.. ;Zt4^y:ƻN'Kn܄Z'6 RB*~BJi¶%FG M3/3?f,8%01/K^incSeў12=f&FAq}Yqvx}SGdSӖaof>U5S?ܧݐGY4 VM-wGp̙F!l"ٰo"bǍA\e@z5*@趥pU-},Mֹ=_+bп3ãV عX:!^J׻9/^SG^;X5DS~)y#2[~GMtٌ.o/34&0 #1s5-94 a>MZ,sci'#j|B31߭*+BXdd6>Ɛ\\]'+N1HLYHK6T^PhŸY/)NZS~22m\>[dry=Km ~ _\?vɍnȷY $JIW K k 0Wɥ`# IBiŧÌ6*6cT#]x;l`c4/0d >L߾-l86OPj=4ۊ\3^ G]Ș8*,v Jlg-q«m>œv<80~_VQ:NOZ\LzjO2lhf&cU">q=,vƫƺBR^ucrF9lt *Uj@Lnp j=g}/.4/YrBT]㺂nİ v jHj 8h5-&J]N?OR0rmgf賕 !;:O^B RQ Y-cGxXHWw%@gF}x6@r(=ĺݕz") 7V3n,{Gn2Go#DO5DQN*Ԗ ޺N 랤ݜ7cU2M^k΅cSfbPZRzf+9VԬv/6N,Y[L5iv n -L/vbKHck.!爚ĐZ:dTޤU㈶C6 WOi/}må$ű 35s66k*~q"ą׉wOv\RnyI҉6p{V.Bh֠ourN9i'_j n#Ahεet۵5*P]M_&A8rqhwEB(ßmhS\Ή5O[l;䶮w _tgV/JbFK#9YVGޒ VNA+w.v'ϐ#!EBG}N`Z^@['nVҫy;3a]\tvC<Ϲ?;ΌCwը&,+#mo".X5Up>< \!#Q{7c~ ;$u*p4$/ٺ1S> 3@9crۅ%W5EYpo zBPo2W>[PW  4AMGd@JoS2WZhYӡDW$lTD F,Z\:T偢(TV/nVbHG_7C2x*Mn뾤Pamo7DŽ-=xmGgPoU`KW|'{zظ sjE)vNvꞜzh/˿| ^)A!$$=o cE%pdg:Т?iI>#40GL㝿%c S),}qg\uzOъ+CSaogUXISHv!׬1dɦ,s8vk {بjmP!ɗfb:2MwOiT`>%ĊS|W|bȼG=>Mw}:$h=6EfVdN1dq"-_PxID,qMpr-|-u9Wyv}uSX:d%xL#j6jnY/%n?hW ? m&.%nBosc}AMIa׫0#M|%k:p\Ŝ:}7ċd(HeׅQ5>yY\Px*ŋI//W No36[g^9I^oNˆf|DqF9s^cئ#o.%Iu&3KjDbh`dWÍZ;mq7Ng#t $$w^-OB ڞ|SAjhn+]DSvlbBMFA+pܦ6r4*qFsP?*tS&5kj+ϲһ%ΡT:dl o@`%>h.kVÀkH̄he_t>Qo2tZb qbaCHX&f?&r ^*fVsXE$aQZ˟3#c1O>∤$ƉZyNP6B@>:";h2k8|;,uWE{o7b 3՘4Mw 7ʑS)#-e6͙ idh$~x1Ms3(e.bQATy)\=j_qPunz!]lXyxH#5]dT(Y5/љuJ[Gl;y8EI_jh颪Ԩw6h+@Ez6MAQ?8*k,a0C 0nbCZ dE2ZG'H 9RH0@<0ѭx7}zںWbB]cQsqc=X9!Rb6 qtesf%(FЍ%{=ޛ UȪeّBr%9(|Y$9 h]m.BVF\FhNm3h Ak6[/un3c~0e;~Y@&Йo/0G_ ‰ٕyFb >nrCm]q:߶4:M )UCrj"~lvgOG}Ll,gL!tUPgs0B(npD?S/ۢ1[Vntzw)W=\Si+`ݦ50 scE!/i ׶׿dMkǺ^Spthl^[_4PlJ<:6nviG/Y JZEX&n߸iMIdCJ8% c橂.Fɖ" &^c1QsKGx$|ut@|6̜{bvKϕM/3DP5ےѯ?Q Va--*)}+\b%}z+IީE9^]/$-XHPU¤>uyg*~\傻T_P4bl0FUf IgC z NMu?&w\SIc5h@9%hrnN-~i%}4}4pI +؜>DW#8n5ax;ޏm36#Ёډif\Ӳ~ g>q3N9|Ǘ&yCW)B*d7 #em̽'!=1\p%9f6gٯ4>4}*5tγh7ͯq*iGVs u?,EZtVg!]GKr)+>J~gJWl17ր.,$`7f}# a[e{$ E(WOXi:j|-}8 Nׇ(Qf p۸`?(3rDG8km), g)meA] 8>*Jgޮ *lyL-R?W81 tS_J8a| Os.=q4[)\\N"HvhSim;y?S]!\N^V"Jbkq\RExzQpZ⧐Kvx}-'>،cV%grxeUd:f"WBg"s ic鶟tZ#ӊ^SDZX(d.i6.NA$[rۀb Y1hH$j(ME65`i#ںp yzx:.1R{nhNn,⊾']fhoMt V9:;蛴%lN55 pr./~%cյZKee(rQeE6 #| ct%~251咍_m4@,r]/TR3ry+E^!W6mz']' TdžaWPbb%SgG"~6 2MQ~,:5K{y;Pon38Hv"r^C[>I %ӹ[4s\ApYp䌖V@gsDBY)ȃ95G0 67!GiCFV^9B~g[< OpA cuX 3u( 47`i.g"Jg`pd,*3var_N [4OLG@溟΂+ 2,^)T ДY&kP0lUmNȎzB~lJc[j8\6胞a$2A2ЎUg%x<8QLӐ]{B2lsϬU#8w݁3,#2ɘ2M 1LYw]NC7oS{El#bL2i\Z ~^<$IN=2Y֏¼}y#j7~Uk=5V4{rO%I:U>;cރvOi ˤ8%Ls2z„o)>GCͨFej ]t5{nrfVJ%)ǮzןPWDr=v1&h@Зol8O{?W&SV:B?(U}Rͩ#bnjJ~X(0ްi@Mf-lV)R!jμ߾\.6j?9]#fBԿƮUʑ&4(`eY TYcMq@'\: Tz9&nVTGp +7[E}zY0= b? Smށ?3- +U]RX>(%5(ľ"zS'Q:8V %|OTǺ?U(^w*L 8JD)ΓٌD*è:"ݚQ?N }J^i8kRs:>gJ*f90 G63XF̲27!r/&kKy2x{: mL`v6a_I=:*~cۘUAGDЖZT1#˘)Ld ʸnY/wZvi2۟fW8M+'PaDeҐ-PAi9|O2FrG3/_Q3 xyy|d5}W`ר^&'{x<2;A1=}x{xM*9M]^#Eg=KF_NFWEKMjT^{_, 5P3=?z=C"/.Y1Uah*w:&HBԱ/u~?Wt!.:N7 #]Zs+7E ɹ{ v.dV?w6)/i( $_r=ӛN;xzKfh#`Q:Cڱ4CEb- Sȃ`NFG_iCapMs3cq!:I^3rM̏A[,s1֗~QpZOK);2mqp Bf8)\T ~[luc++J4du?$SAt3REezg7dWK']4#{x>{X3ɑ;uS';gYd.-'B6iѴ!($;gAB7?nŢ00?ȼKd\f!OQM~OrS'Br&44Ґ\A)Eb$4 RPoN\&"2 SW m.>l^9)dަN篽jb24T4B7񇣼.;bK Z(¿vk#P>y[:UN"#ϡk&.-e XH{KZ8|6vsJ<+3фj"' &);L9y0Q5n,F*vnw>2uVaDi g}.8=K(ن>J^xzֱYzmyrTIv?섫{rH#몕l6hn[24Cy-EpF\I7e$[霞-:O8 W}4\wC)36 =l)>?g탮oM!O#Qi~hycLms(:hpIV|L/QQvo3k #mȒ+ J5oKa&BW *% uvt2DϜ@Z*;Ppn[B篩Qnag5 B_5[%Nռw !ö%;Bw c/?CuotĔɸCv^soGR<\i$IK?Sn(60|ԼAD1T\bY[ߍ|;ab.{*Eޟ~RQ}!G!ǡ>=M_u`#ݷB u]xY(j>PUT6Xū )zc̲.0\,0j__,q+=~o ~|Q]q>3ʦd&%}tġ5 ۱",`J~ ^[n<@<4}1a'|| w;q7b?!fK֥sRm&t]gEzA 3-3zTAlUzOz8Lvs4ΈhYp{-R!%mmX2ۧ~|YےZt1,/y!TFLZ0j«3ZqK0J@Z#}kwic7< JQF^IOS~CbB Ac/&G Pz)OnŝdiōG otUÞr,]>V\D>FJ%5j(7Yt&F\9B i+qb`" /r1ũTV^%@1ȑ["p\:+Zh2cJhQ\PWu9(;Q'[H!;4FNuM |CK zaoK=P4 zN jdĜC e #+f.d84)/}Ԗ{$ ?S~P@i⊑v Cc. k[M(vْ$Kjғ#\wcu W!FWM.$Rx4촓@gb bOFXJĠEb(9\jI}&$z5Y*ݞ2 !VGdpV \ jI)*ys(;`9kQv9'G#cr?A:va/P1c"s k7}y;KU5i3QqIC01ʦ]ą=:wC,?@cAlBE9iz>hܑG%25&y\ZonԻ=䏯1 V2m`1Gb]m&Μ_JќU7#yGudoKGP84Hgb@P*"nN{H\ B8_˰&bv;&Ҋ= Ř`Gl ! n%퍽of'9W1}3R$Q-7 Y 7/h:YH`nq-x y8cwo`˷2YC:@B-s3O!mQF[8v⓳bOK'8e9^ ~So_)Rq"kS@۷SH,Rل 9ꓡϔi_9#0F"T<ל}`}eg9 #1 Ui̓f1xI-1x_Mж^ʮhD2h"c[> 5Y^Bja8 zlj0Y0G Q^ԭ8Uis2pB8Z+~1hVs$FF*݈ j"CkRӈ5HE9)ټ/zsP}vkC#F-1xնmc6)* $BwdNv]UkK>ڄUZdWOYR>%,"9*CDۏ5uVCPI(ZHCWC cȝqO*.315X6.}ac فMdPClF>{;=EΊeSpY(34KI@LpM& q3~gaCJ*b  󿄎dZԝ5YJ?g"* uww.,)2 h7Wl'[cf&X6զT SaȊL@8ATt%P' S:n^ +aD 9sj{k*"a goDYcGgw# *Xur/ٴQϜ#d*;z{z`0;tV\$"" W=*!z5ݫxG>{"/kkwi>Rgҟ bbLäD_O g~F$?+Fҿi@p(/pY69=W -(AWl"MM2)}"1FŐq`'#zoJˆ3!U-{̋8,~2[m5̯6L,8e=uh{ ;%=v4-@֪: ""&F5r߶mVKNlrPc(2Sӧe:g`R%*n8#;LN8@ZІ8 :pTeH0gy]H Z`u0y%:jD"E϶FoCm!4Xf[]I7gƅɓ?qiZl4ĭꃑ(wGCyj|<#rtGŅLܩJ?<1pvCȃ3?'_:(A &]2m: x?85n(!lzr%764- :;B 덧+'xpF*{i`#rb3u j `ް:lnh'2r7v`HxcNR!<-!‚&1?|CcırYEv~rb8Cͼ PfZZvE'I ^m*ȡ ff$]1|oX|Vɰ&@O G\"?X?L]Db }?">yf`1/8j94?:U[UUD]8c؆rMN7ߓc-Ͷ&x;7^ TBcc4.PbftAPhڦ "@bY%P]v?\ʄ)IQ+diIºLΊ_%VbAǫrA'9#ĜD_UsO7LxKlq4@{d/GbiIw.|$[J4N:m}%*VoE;Ǒ- F8.a*x3K3Dfw=!}i#_h}*LS\]Q1@3KK`^Dž]}Ygw7N&2LRFԚFຩ!4 0>a GmJ ^q}P6xFt5.a[H\SoEVM-ռ|e |] tI jV}DH g z箎_3%ٙ \&} !3"#x (U{ݰ%$ *Sƅ m_GV-*UJ޶> stream xڌPi cn&\݂Cpww ng&9E0WwC {s_e92i؃܀2؀Ee@W3337+zY1"Prd%Y|\L܁Wg7ϟ"9` #-wy`7;z6눙TuTE)_'`ppEOx[8xNܥ%P4Rt-@{9,/3+ߌ$lmSm7zc[7W(87j^\9je\M boio#A. O2[klA@eЯt2.K%-+' ̧#0ҿ̧T#0oSjF`>̧/3F`KIYbljMLMl\lM\36u61-\s#{ {:8#3[8/ "d`kk8 ` H9 op~A5# !-,@vplbi.wsMra೶Npclo=Tx~Sqcك=/;;G A#1$Ꮡwl/,LN*'7Wφ!eG_Rp?no:_G9.ۿ`rr1সz8;}0_0.fv|@p=8g|,=/7_?@' au/ĺ>VaoJ`bO+gչ.&+hZ$ymcWJx礵.-Q(^uvaeghDaA]xW3["ɍEc@ʳab}"liOeSb!Z#J?t"4{֕5-ƹ'9.,a,OYIԖr3 # xoz2̶Ϋ,fjI"xACim_~(?|0@bXo|2/Zp9+l *EK^uedj\y8~yO=/UW;zd&t{uW-|LŚ<@ftìsa<=38fa-Uf}y]%"@0*6@PE |FwQNS1{6T~e {W)Tz`W'P1ß5W/ H%gsr6b\ b)ƌQM\+Kt\f0lA. ~aP Cvre_Naۇ((ZK֞|vOl•;\&dz,G4[FJxPTsDH [wt..ay E?Ng}T3b)|82q1tADLMSX?Q̤%i`#],sniܛ]$d*9: RgV2}ɗLi>ͬ"e;<1ͱ„L3p"of\vH9M~hYeskk, ڏ+"qo5a~pQf䟂W=~eD*w%a>GK)|/`.r5Kr8^=Nz9 x I 88FWB+bZf<mu5!lC$#\$*3gBoѢ`ͮmaBgP܁ v2(NO%G%0<ODz5Bz}kVzz.4>wɇ 5C%>E}zN !_ 5qm44"^UcP6+zK˜Juͷ1Je!uR (R!Mv)ej׀ A|q' ҅ 76 EuJ[6戦sWHhmfHN-rNr@--=y{pP.G>rʻy)pG$8^F66>̘]'2ǘ $_{.FhE+*dsar 4}Pfvbh2ƺt3}6i$/f[5$SXy,oxḒoQ$[|Pyg'!Bc[V4H CNB8ݯ݊M#AfC=(2ǰkFYԎ_!jLSW}5;dt[U I6֖9҉yzw*fR)+~ W y{ү&L8gp:|l kj\*!4 HVq 4#" #`\EN Dw5w)T6kn(}z7)8f$Z0$Āk`M=»7m%X.ȎGU% K~y_( ]̴cC jח9?$RYφdyU/>cn/z$M?)Zz#bCeI#/ӟ$m^]v)YwvO|8RISqwBBGb<񴇥 ֜LVGSqDt0ӴtB¬ef>׹]Yjq0^ Γx$\[K!=7jTo}[OLlM_ XA`ί-&ؕ~)R|8)Pt'R" !}QC&=uem>kTcJ \1Сv_Dے{Wƾ،pXNaAA[v烟i.b t#` UHcpgϿ ;ɦhRvcjR߅HÏ Oq+8iE_lTRӒ*Oy-X(J∶ZDeOpUtRɞ{q[7 aT|Dϡ,8ݰ1*&C²k;)9R$)LE+m>W%Ng?{9zChFq&S$Ft> Z#wgMuאq)AV[L߆5X.-žcVb9" Fw߈*O)ۀo!␷O#\"2l'b}h')FD^1':|{?oLnC^|'d'h(gUڛt^ÁuܖPk1PATks=g,EdITdIV%օȮFKoljKj{ڇP+lP w#7e!j(8wρE{߲AQDK]QW7Iȭ\-i_x>.1sMbgYB*=5 ^͋,VU/OU[V3%9Uki=^f4X GȼVlm/trN "LA(uE: XI|=]Ns,ьsN{9'Lϒ+~.zRwᗲ+- x*|^ֹ O$D%dEޚ=01jN=u.G+a v,0q}m芎O2w*`܋\lDoax8GzP5W$[܊XҜ#w/XYzJB|ع[B9Z{|e8GC%iCQ8"BFN{;oK> T/407M1/E'Tcwc|q$e $}˄qIYƫ?R2^!댱e@r"iZtpGk Qd T0qt̯anC6|7@kN=˒G~5pJI}TTF%jqcxؔOnnK[ 9evrF^ OMoڄ*5jL<ϱhLCTYcsK攚}(91C %,IeqdCea|L%LZl5ѶCҕUcoHjٛ)M긥*CUg Y*p: 8lb}%,m ~MOpqd2>-*mfJE:-w$B`j爕]v:Oͤ7 'Va`̹}C,{:eƲF5V NGHoF/ in2MJSM|L2eg5B>x,Z]%.Fƫv9 WRݗC/9,i-G"tN?>'qՔQ)r{*DPIG!|# 4_qV%ѤoZ)Ƹnj}yvVNj rxk?F_ɶ.Zqx(޵6=oTݿɥޑ5`+ `EPLheSBs'i^7IWo|M'o]W̾7MX`jz\Fz]r74Wq7[i55`ROwfgV)vDn0BOoQˁ6Yf*e.M$4vǏIͩ^^'`ikݭ|W%)[HX6''8j+e &L3ᒀ<%DnA5`>dI$;*2SLG!vf]#WM/D%oEʰ -f0,1i1EY+Hf_Q` Z}㔞RY;<5p(Ҏ U{8QFyDa +.>Tkq)j7;OձW6Pi/ڑ" 5MKk;uLj]%\\h]3Nfz+ɥ GE :=ٰK=hVI~ͧ)^ O6Vh _# s_$9HY/:`eU#nq!.,*>*y*DZ'kvB5Yu޻e+nznO$$zzq C a~T:m:,v;O|Е,\L:^J X"?&ǡ!/=.Bᚿ:›#@w[C9e*8( Gk~s Q9h" /vW}uG*^Bqem .Wj3 e* 8?"N;(`q8 !T7W5v8G0\(LCA<#ʆ8՘!$I -I4Hޓ"^-Wj M6~JIcIbyyg͙yIi*kS E mAeGGx}p~8>YXI.Ò<{i~VSlU!Uf?([L(#śl`PJN|pA'm(@jr*殽3zG=fA{3[(j/߹1ot7,+PYG;8Z6ϣ{}\)T0b$ɍUE ]ګo1PSY.ObŦ hPpүQѵ$V:ߐv wG5Ʃڮ b=hw̺ILvW1/#EI u1.FQqKwOzƨ$TtGp= tșm(UBEYА<>3|9x̔/IER!< Ԗ詊Bfl0z1\zL169gv|f0N."d3b<5p}7`QǑu1蘼"{-+>E`&p}.{] q遜Y&YUFJa]9; tV9-0ptgq]+&U<\WN#pÄ!j}&-'Y$_ ;JB=#%kod 'Uz}towf5*Z]dsjFuA ȃHKͣیCq* q#" 1pHLZ~qe BW^5 DLل?U[|i(wM3LjiT=,+^~rDH K͑ RiXԍřZa&=OF%#}^c ?΄.[ 1#)wT;\jȱ+po"rU-ǃWh\)P8ǼCA'`IjoQ߉ ]P؜pj=^[u 2b[y#SS@j5vC2H5S@+5kҍ&mڴ }:9BJe - =bʤ@[M \i;,& Lq9 ZoPJh8 mZ_}U& ҆zE@Z"wj׷9EIR+Z`k/ Ry9giYS]㭪SFǥ+pOŜi:h[jY vh${6PуtM^ E -cEU Ԙ#5]>{6(bƾnp#3=r8|Ͻ%*R<8xbS{R$ iz̍t̖'/wQCdW7taCGY?!vScfb_I61}  ԜzӚ3 gAI/Og.3ӑԿ|kѿ_mRS ̾}f!(n 2giJ=ҹQ:výLJ<0"ߔ8'|Kۢt:[Mn JjSvf\G\&VjKVX-$klXI`^j~ETS6lDQS-_kO?wL^ ?n1Ll_/ W'Le=`$+W TuU@-*"SG{D@]GYw y l&Z0|GU5Nh޹,p[5AIl^iJz'ɇ麣PJϹWcl_av]dPM>{jaIi҅pej@W H䎞Iϡ(u;rT]sauY:FeYgxߵ޶艥9C0d>D![x\}U㮽M+&¡K%%Zx=A#晵}!te!\n4Cl},4! (LdvkOQ?/(BSm0M@8ۘRWis{Li2 ʾ)f^Q!z=)d5(Ⱦ?+r%%S;sFTg# {4K*12i{nZwvaG@roeT&moMxMWxsQ~RÄ\Bf.%L,bdaʫ\V*ΑG{vTRr4imj0nx7;ӗ_(yXV}_?cZH)Ƕ86$]F0tIscw;J-$o_WM'Miq>z~M2G`nG JtKتBYۑh2xY2L$\Y \6FgN0PxDlm$ \dL;Y3Y..9(  ]GI4ܕ~Q" ;F\{;rfTEc$h{7{l5k' q ilUhJRE*KV^_T*\|ګA Rgd |\@H5^mk8x;@^>A#峸%b3@.^!IrW#1rby:=OWDBRbS"eB=9B]֙2<^U)$TEJ&2xU̬-*A)],&ҫzw@6vUl0\ѧcv*uCWhBGTf\^9v p0vY[Úr9[yʏQ$O%WZ}U?gyLK,9=<8os`l%Ud[%F2qBb$0D4que5EϠkI3e2 4 Ҍ -+ 5s* l1vv 65(Hmu8[(92 7e]QE=EW Piz·HD/Tߜp}s=)Rr# .I5\ɥ_W$mGhÄ_12*k9Qw(_ #9򯯟I ^\%.G|҇U~SNŊ8R50$(km`XN팓.6RۖEDoJUVF/OP>e(I֮;n[^ȊO~[vY*2 =,JW|piV&!g6EݽԶ){"]awnU,]Y/O :wt?{ | 5T10,.a芗\syǁ'Z:uz9:7b.x WU-c1//Sot[QE1n>P21Γ[Ή`|P0ºO" Ь/ ?\Oٓ.JyJ8(Zʁ}KM>CNu:ﺝ4);v79eC3ƮMD%|W? ĵ;&P6W5Lfܒ~mػQl+ʲYÎ'°h}x\f\0.3ޡ`Sy7/n*3ͭ䨛jDyH1f?E2ֻMs&'u+Ӕs*\2ad2:':-kz3yqM)ԻbP-;ܝE[M^ y@ޒaI|rqD䞣b Ctv<(+th}}1'},bIv G&.?]_1ѹk%,4=A{in%nFe%K)TV4L(h !s~3${^͖'r $4nʠ Nǖ>BrzRSXo9\*z60HAX_6-^=]O*OYzkH j$R;ʗARCS!0kwP F۰-/-@Ժ|:Ts3B7ϗڍ, L q!VzZZ"I7G5M2.UC-{jux,0M]hV3s:(Wa;/}&^~ւДohαF A$a@Ftq|;ӵhp0{#nh{~86*3eB)FLpIYAz6ˣ 1. 9Dqrb7;(L0?bK JpZה+x~f:אJSTP 4/Z[U ?+"Y;:0> R "!Wl$>د.(! (qLؿNM -nD,Ⲍ9(,ܤC4l13L0fs?p;"ٜIFRjVȱw=?x:rdE7QOs28n>dYV~jV(%3)>?*`֝(q ?0}k|DCmCSי0x?d@[4Yǩ'+I6hJ*hdn*B_/~`yZzc!<Lـo̶̤eMX [̓\`̦H5l %5~.$$[#î)}kAB{}ApuP3Byԙ@ҫN}̤~ςi"Q"dҸi;ڴ( h׊A`@ 0Pra[kvC74o}0&פ TP_~{[\Ҥi lX7ȓGf+lBj` 0Ce6?RkZra?]lHE+c0f1~[ܧZ)j35!gb7%plKDN } `|N )\9g0Re {"6>XDnQj'qu- J)gOqboֽ|кy;PDŽ9xI0al%'㨅%p0 .JWn;GVg13¦879eAqDIs]ccJ6+56"|_=MuF+R(" uR#2M3=!k]9>^ZL:O̠\ E z3b*$©;;〕 ay5/$N$RLhۊo;4Nae׫XƺC: 'l$Qi~/T7 6;kR4'}.R(?0Z󒎃iENYzxp&et\SJ{RgjQږie@eJ E_T ؑNrjD4<,&+޴w OYxk/pb3EFKPڙڕ4B7I(d)5Z>7Tzme`V, [t2lЈU9yNWZT4/XD zyEg0JW)lKh%gec>2f/qV$mq{S.N';`CmUݍ݉K!\ TqJ mU/}" htwm  OzC4i }vǯ-kVF[^'B̏e2$aߞתIh]eV|1f%ČBU}0Oae/*(?ι4gnU5khI;bywZ"ct_ tY[,rH"_ @W 5k] =s"@0݆l,& }b{yCߥْ_۾82Xrk^zd-db^L!$_={X`p!XsPL+ Odme(x@%}Z#HhE,T"Xv[Ch:9YOxm7ҡeeZQ%ҁ [dR}u͊t#41i[ ΕN'iHIF2J* sQunnƞ̴PeΧMaSxR`y5;*-fK_vIpv,(c+HDJXrvlW!nB}_ L(sP~>l9?yMRn܂W_g8N¦}@zԖh7D=TY{3"|ȊCN=݅fW<VB Juflwv1're7RSra2d(q^eHǤsaQ'FLR[$G7J-aU]Wt2gʴhj/GZ͖U/d}~`9c|'SLj2$p}Yk==>jfF]@%Y)&BϹ2*Ry{^<%(M1#_!AG$\Ԗy~kQlUk\goD1V @(hj=D M\(aL/x~ءP-L 0aD1kE3]ՁdD}Tcu>&ś׀MX> X.H[)9&e $ iCB"r&{k ;p'(1 0n!/_u8GKIK1|~[ƃ3yAThEEYd^;%ă5aBCLmr.Hiʭ7zrSI@g;c=ed}h5Ϩ$C2aNX#w}P8:LO`vIB}M(܊12-t >x3Pgoa(g/wW\Et+u h5l.&QV5ss@vp/QPj9 N p"U`MK?gĀӰrb~:&>baMZ[THYm'DҘַR0?dCNb)`XE[(kL;`֎;޸`K;''aAwιZ(죞Vg. zU]H<+댠 t莛yHvOG@YMl$"sNyՙ0|vC!/5u I(2,{i;toGohE'o6i2K3dD2FEN@M}Dpg@7\xH*7k p1X<9O'LvqOvy>Rp2x/_nNjA3C4T #%x;K+땀Art*m1о_KͧUD* m2Z.UR2P˕[S C'g~HC_*L;`ISgnH4ww,d2TzVjvrTv^俁\%ic endstream endobj 256 0 obj << /Length1 1608 /Length2 3591 /Length3 0 /Length 4598 /Filter /FlateDecode >> stream xڍt 8m>,V~,-[F}+-c7Lfaf"kH ٕW},$$gɾT|C_]s]3sss<"V2h (20Y*kbm P, gRpO;-H"c?$IN )T zST)B UI$THO,0 (Kt!a](s~QLEEIz7ƃ$, ILO=VDB\݅BqS@dx,|\BR\K X3@ a,KHHzđx'C:Q #v?2ueXN41кD<$PȌ;@u>J z~" 촁p P(TYN9 uv܈nŀF?2($0O߈Xp٩fSNCНϯg C 8+iYKhSG <U#?4 `bSYX \DnA@ P nO;YW"NH<Aխ&D&K/ z5 Mp$zhs,岫f=a 9yYuP׃L 'PDΒ$aRWP`mD޻" "P 0DΕ**.R_HE #e/JY@j(7BU D yBRӑZo? 0? C]Q$-U:u? ["J-BqHz6X;\y1rnTs"XW}cIvTv>nWsB]'Gr+هq(yHc>nTWw9_ikYK∴XwꔾheZگFRV.v|"7EGSMpҴdif7I ٫1S.͎؈Pȳe5 cV\ۭW `洔IK![!L=l*,VRrB q0LԚ,}[ε% yп1P9PA4Th\mNeR*dmHjNh^){+l vbϐN/PvoN\4f0z'6FtHXNQc$D,DK2Ƿj utd2. V|w|VH[Pe Zڹy^a(XL~_0,Rl"K`zDSto.-|E{B8hbO|sZ0z"ϔ唷.yͮ,}wHFRSESRpEБB|K;-wR`G1^㱄8hx5\.\HOTXt >tޣAAϦ8 mg0;S7y&_6.37@;7;(h&bt8i?28_T Y#O& sRM⹣V2R_L[gwp_$\G+3ۂ:][)k.Hhή%J<,-^QGÒ5Cp\{ }qI ,o&D7೪G4\5Ͷ 9gjlFř(xaPncey/HVqG3E=s`\&]E^z]7gk3$6c15s'bz@GKBQlVxSC$oiYD }41xT i ۺ6 ;²-`)kl[xp栖9inΑpd+į> 6rAI@s/tRpNCU+6sfعeq~0;n~?5e^VNVef8@$x\)mfCzO왖X|,rHƣQz=%BOG=h˿x8h-+5rnT䡻74 i,3$PLcL9x*C8t8P|] 뇬mnVzy&`A`=|('GilW˱5GFJ~<ƼD)d"ڜ*gDGWtc* =|<9lأ\p4KL_ Zi<nOOKm\tdWXc_ߧOaP;ЬOfoh]WbgԨk{OkǜLl*Ȉ)bc_v2"}ą.̐gwgt(Ӭ^sXzWEe>DNIW aiTVA -ֆG{s!sDXaјZaT͘PvMzmم2ga3]38נ'o"=#Hk虮ܿ_=`yDX;W4D_WA&fq8[ =ּ1fP1:zK[\&ݭKA7_ ?cZq݆ta'!l=TyN3}`HV5>RtO'sӂHpha$߅/D75gh [!m>  8v{ގT|LJƑ!ۅ~JV`ZfWqS,xXd!PMxڑCfO]:r %GՎ4o+:c(WVqj,w%W{R6\ ~{[uSWN _@;]*2(7 endstream endobj 156 0 obj << /Type /ObjStm /N 100 /First 887 /Length 3612 /Filter /FlateDecode >> stream x[ko9_'X~] HqkL #ulmdɣG63*i)Y\bf"ԩ"EuӅ,KERP-Bݻ$zUWjՅQEGX;*"ꎅ6*AEʴ& 1DDz F984#f hh&B&b:^mRUh)%ZiEִQaXh#]G%Jr46+B;yd\J`ba!" JQCLBoP%!%MhP%hCa kPčv{$GkE Ӂ+QJ"faweo2 2Rzp0t0x֯> =xo8,M9 Loƣ蕤oz_%MN^WE$p.HE͇d za[ #veм+m*kAı]$wa}[ !lOx<(YZ6_ F@_MXĹ8y [dۥ 5u6{0)帀~b$k" ٞpcI ܈#G+7Ḟl;+w@VIv>||J_ѱFkTu{\e.aeJӵ8I~d Bc< qG1u~ aq[$s,"ɶC+FmKڶ%mKluE.uv^u{Pڳ{H`J^e8` ۆVi !c$A[(y,zkY ]2-HG6re͸h7~~Y@'U^wNxf9C9^Yk@jo4 qOJG .%L"Cـ\JJy9`-\ف*9q~ѹAN2Dxb1*󔭓XY8xdgD"`$I^v >F+47Up8F}*qVse]鼥uXeKr3K,ayKM7cUP E~?Qyhz!%sLqO vrAjj)|LzumU[Iw޺uچo)Onen!+}2mrO('>2†GjNHG<֝v )4xz"5ZӍԺrVKܷp-7W}y%DoR&tQOA&.,#5,G{&/tR3f\_IY~ e)kF>%=g[vb4(.iF*;Ft[ DlGCgqrGez]WsW4OEt{X)#kÿԺd8-㖲:Z\_Iq_F(+մ7Ɠ|CU>|r$:ʹ;/~tHwq<* 'jps;;uxt3 3~#vU=|_B71?Dř8/KJ F\_[Q'zx}Q3q#nH '1wb$b<ĽKVz(&q_M㾘V1n:"fbv;*1XgE!VVi+w_dgx=x›ތ=xʥ(ɴh/pθWixAٳߞ,HLlՔ|! oRy-CZda/ϟbI8qH1~8DW-r*fL؁E<g^r,޼ 8Zph7= ՆW]Bzl3^b4}@ nt݂Q{IA[ճ;+lGm؍M?#u"=O?kg[;ylm‡bw\wM^xб9r9t'ȮRN)O?Q\!2TU2:ᰜ<N@llqyЁWo/3K7Xb鿓YvsQG^;xmOl򺵾/˪6](letl O`sz9=I>>ysnkR@6V_!ws51;|+mi6g^oN>co~sWڜ}zטLwoq/i_8>J endstream endobj 277 0 obj << /Producer (pdfTeX-1.40.20) /Author()/Title()/Subject()/Creator(LaTeX with hyperref)/Keywords() /CreationDate (D:20200114123151Z) /ModDate (D:20200114123151Z) /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.20 (TeX Live 2019) kpathsea version 6.3.1) >> endobj 259 0 obj << /Type /ObjStm /N 38 /First 307 /Length 1130 /Filter /FlateDecode >> stream xڝWMo7*3AEӸHSb/l˕E_ߙ%wERA"9;R "4 @+6 FzA+cE# Up"$8Fgz@-ɎljyY&X --4҄1H0dqKۡE8)@(EC\N e4D}E,Mvoty]Ϗ=X7)>wۣ۟Њ0qHcZJ{88MM#U9\S0Nc̉_ʡ/@i#FF%L$Myīq< p8H6-faa5; l.ʴ>2йj0-{@HBW'$>IK d:ɴ-">U56#'bqwWʯ9άZj}Bj*y.ZHK(vF0 6ȍ؄"!7.rÚys ژJe.XԆRmeFy 8тv^%*jK\bm`vhg ?zz]}߼2FO_7⍗L7z?|=[Џr<8< cEtZ3L|\=5;%y[,$+P[\Mtq;#/h:G4d EV[܆z_l)p[|lɺxqexH`ڳRPbΝ)^pMVY|ڜX;` MIc3(evtS50o!k+Mmequ$XS.+- BedXk/FjO9M|2wYqM̓mڸeRp䞗x2u8*vm4v9+ L>_50 vfVZ5섯 gpQEŬY+p +O鄐^6aXqko9gp !gl:9 wz魅N?/N(~7w]<V'w/~?waO endstream endobj 278 0 obj << /Type /XRef /Index [0 279] /Size 279 /W [1 3 1] /Root 276 0 R /Info 277 0 R /ID [<8A57B38EF2CB67F1CB505021E0B250A3> <8A57B38EF2CB67F1CB505021E0B250A3>] /Length 678 /Filter /FlateDecode >> stream x%9OUQF"("{̓ "̈2O* 4&habbWV6D:6jP{K٬;u,1{F՟S9HYUdǨr>0AVHT@%;BudTpKFh_D!Z)udEQO5L1Y+NPJt2" ӠLcUJn2M^A u4Fp4fZINvNNptn0fzd=죺6:'9΁Ap L ҦCna.G[9W[jY.K2n [Ӑk` n`l,u|P"XbٹEP- F0Bɺ؆Vus.7ݦUmy'y u0"mG</DA\ i綽 'Y1[-HeѦEngԂ!m5$+Es`gNԋJgouQ3 'Ş2t ԋfe-H^bE|e8n*znrȍ1M, , , lI 41 p#fۗG`=]j}龪;ݿVIveO%Hx-^׮5= 2). */ #include #include #include #ifndef _XTS #define _XTS #ifdef __cplusplus extern "C" { #endif /* INTERNAL SYMBOLS */ extern SEXP xts_IndexSymbol; extern SEXP xts_ClassSymbol; extern SEXP xts_IndexTformatSymbol; extern SEXP xts_IndexTclassSymbol; extern SEXP xts_IndexTzoneSymbol; /* DATA TOOLS */ #define xts_ATTRIB(x) coerceVector(do_xtsAttributes(x),LISTSXP) #define xts_COREATTRIB(x) coerceVector(do_xtsCoreAttributes(x),LISTSXP) // attr(x, 'index') or .index(x) #define GET_xtsIndex(x) getAttrib(x, xts_IndexSymbol) #define SET_xtsIndex(x,value) setAttrib(x, xts_IndexSymbol, value) // attr(x, '.indexFORMAT') or indexFormat(x) #define GET_xtsIndexFormat(x) getAttrib(x, xts_IndexFormatSymbol) #define SET_xtsIndexFormat(x,value) setAttrib(x, xts_IndexFormatSymbol, value) // attr(x, '.CLASS') or CLASS(x) #define GET_xtsCLASS(x) getAttrib(x, xts_ClassSymbol) #define SET_xtsCLASS(x,value) setAttrib(x, xts_ClassSymbol, value) /* IMPORTS FROM zoo */ extern SEXP(*zoo_lag)(SEXP,SEXP,SEXP); extern SEXP(*zoo_coredata)(SEXP,SEXP); /* FUNCTIONS */ SEXP do_xtsAttributes(SEXP x); // xtsAttributes i.e. user-added attributes SEXP do_xtsCoreAttributes(SEXP x); /* xtsCoreAttributes xts-specific attributes CLASS, .indexFORMAT, tclass, & class */ SEXP coredata(SEXP x, SEXP copyAttr); SEXP coredata_xts(SEXP x); SEXP add_class(SEXP x, SEXP klass); SEXP lagXts(SEXP x, SEXP k, SEXP pad); SEXP do_is_ordered(SEXP x, SEXP increasing, SEXP strictly); SEXP mergeXts(SEXP args); SEXP do_rbind_xts(SEXP x, SEXP y, SEXP dup); SEXP rbindXts(SEXP args); SEXP do_subset_xts(SEXP x, SEXP sr, SEXP sc, SEXP drop); SEXP number_of_cols(SEXP args); SEXP naCheck(SEXP x, SEXP check); SEXP make_index_unique(SEXP x, SEXP eps); SEXP make_unique(SEXP X, SEXP eps); SEXP endpoints(SEXP _x, SEXP _on, SEXP _k, SEXP _addlast); SEXP do_merge_xts(SEXP x, SEXP y, SEXP all, SEXP fill, SEXP retclass, SEXP colnames, SEXP suffixes, SEXP retside, SEXP check_names, SEXP env, int coerce); SEXP na_omit_xts(SEXP x); SEXP na_locf(SEXP x, SEXP fromlast, SEXP maxgap, SEXP limit); SEXP tryXts(SEXP x); SEXP xts_period_min(SEXP data, SEXP index); SEXP xts_period_max(SEXP data, SEXP index); SEXP xts_period_sum(SEXP data, SEXP index); SEXP xts_period_prod(SEXP data, SEXP index); SEXP xts_set_dimnames(SEXP x, SEXP value); void copyAttributes(SEXP x, SEXP y); // internal only void copy_xtsAttributes(SEXP x, SEXP y); // internal only void copy_xtsCoreAttributes(SEXP x, SEXP y);// internal only int isXts(SEXP x); // is.xts analogue int firstNonNA(SEXP x); SEXP extract_col (SEXP x, SEXP j, SEXP drop, SEXP first_, SEXP last_); #endif /* _XTS */ #ifdef __cplusplus } #endif xts/inst/include/xtsAPI.h0000644000176200001440000001003213564762102015013 0ustar liggesusers/* Header file for using internal C-level facilities provided by xts. This is not 100% designed for end users, so any user comments and bug reports are very welcomed. Copyright 2008 - 2014 Jeffrey A. Ryan Copyright 2014 Dirk Eddelbuettel This source is distributed with the same license as the full xts software, GPL (>= 2). */ #ifndef _XTS_API_H #define _XTS_API_H #include // also includes R.h, Rinternals.h, Rdefines.h #include #include #ifdef HAVE_VISIBILITY_ATTRIBUTE # define attribute_hidden __attribute__ ((visibility ("hidden"))) #else # define attribute_hidden #endif #ifdef __cplusplus extern "C" { #endif /* To aid those looking for answers on interfacing compiled code from another package. This is simply constructing a function pointer for use. static RETURNTYPE(*fun)(ARG1,ARG2) = NULL where ARGS are the types accepted, comma seperated fun = ( RETURNTYPE(*)(ARG1,ARG2)) R_GetCCallable("PACKAGENAME", "FUNCTIONNAME") */ int attribute_hidden xtsIs(SEXP x) { static int(*fun)(SEXP) = NULL; if (fun == NULL) fun = (int(*)(SEXP)) R_GetCCallable("xts","isXts"); return fun(x); } SEXP attribute_hidden xtsIsOrdered(SEXP x, SEXP increasing, SEXP strictly) { static SEXP(*fun)(SEXP,SEXP,SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP,SEXP,SEXP)) R_GetCCallable("xts","do_is_ordered"); return fun(x, increasing, strictly); } SEXP attribute_hidden xtsNaCheck(SEXP x, SEXP check) { static SEXP(*fun)(SEXP,SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP,SEXP)) R_GetCCallable("xts","naCheck"); return fun(x, check); } SEXP attribute_hidden xtsTry(SEXP x) { static SEXP(*fun)(SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP)) R_GetCCallable("xts","tryXts"); return fun(x); } SEXP attribute_hidden xtsRbind(SEXP x, SEXP y, SEXP dup) { static SEXP(*fun)(SEXP, SEXP, SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP,SEXP,SEXP)) R_GetCCallable("xts","do_rbind_xts"); return fun(x, y, dup); } SEXP attribute_hidden xtsCoredata(SEXP x) { static SEXP(*fun)(SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP)) R_GetCCallable("xts","coredata_xts"); return fun(x); } SEXP attribute_hidden xtsLag(SEXP x, SEXP k, SEXP pad) { static SEXP(*fun)(SEXP,SEXP,SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP,SEXP,SEXP)) R_GetCCallable("xts","lagXts"); return fun(x, k, pad); } SEXP attribute_hidden xtsMakeIndexUnique(SEXP x, SEXP eps) { static SEXP(*fun)(SEXP,SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP,SEXP)) R_GetCCallable("xts","make_index_unique"); return fun(x, eps); } SEXP attribute_hidden xtsMakeUnique(SEXP x, SEXP eps) { static SEXP(*fun)(SEXP,SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP,SEXP)) R_GetCCallable("xts","make_unique"); return fun(x, eps); } SEXP attribute_hidden xtsEndpoints(SEXP x, SEXP on, SEXP k, SEXP addlast) { static SEXP(*fun)(SEXP,SEXP,SEXP,SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP,SEXP,SEXP,SEXP)) R_GetCCallable("xts","endpoints"); return fun(x, on, k, addlast); } SEXP attribute_hidden xtsMerge(SEXP x, SEXP y, SEXP all, SEXP fill, SEXP retclass, SEXP colnames, SEXP suffixes, SEXP retside, SEXP env, int coerce) { static SEXP(*fun)(SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,int) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,SEXP,int)) R_GetCCallable("xts","do_merge_xts"); return fun(x, y, all, fill, retclass, colnames, suffixes, retside, env, coerce); } SEXP attribute_hidden xtsNaOmit(SEXP x) { static SEXP(*fun)(SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP)) R_GetCCallable("xts","na_omit_xts"); return fun(x); } SEXP attribute_hidden xtsNaLocf(SEXP x, SEXP fromLast, SEXP maxgap, SEXP limit) { static SEXP(*fun)(SEXP,SEXP,SEXP,SEXP) = NULL; if (fun == NULL) fun = (SEXP(*)(SEXP,SEXP,SEXP,SEXP)) R_GetCCallable("xts","na_locf"); return fun(x, fromLast, maxgap, limit); } #ifdef __cplusplus } #endif #endif /* !_XTS_API_H */ xts/inst/api_example/0000755000176200001440000000000013463273734014345 5ustar liggesusersxts/inst/api_example/NAMESPACE0000644000176200001440000000006512473475737015574 0ustar liggesusersimport("xts") useDynLib(linkXTS) export(checkOrder) xts/inst/api_example/README0000644000176200001440000000102513463273734015223 0ustar liggesusersThis directory contains a skeleton example of how to link to the C-API The basic requirements to use the exported xts C code is: (1) Add to your DESCRIPTION file: Depends: xts linkingTo: xts (2) In your .c files: #include "xtsAPI.h" This header file exports the functions that are public in xts. (3) Compile as you would with any other package: R CMD build api_example R CMD INSTALL linkXTS_1.0.tar.gz (4) Try it out! R> require(linkXTS) R> checkOrder(1:10) [1] TRUE R> checkOrder(c(1:10,1)) [1] FALSE xts/inst/api_example/man/0000755000176200001440000000000013463273734015120 5ustar liggesusersxts/inst/api_example/man/checkOrder.Rd0000644000176200001440000000214113463273734017456 0ustar liggesusers\name{checkOrder} \alias{checkOrder} %- Also NEED an '\alias' for EACH other topic documented here. \title{ ~~function to do ... ~~ } \description{ ~~ A concise (1-5 lines) description of what the function does. ~~ } \usage{ checkOrder(x) } %- maybe also 'usage' for other objects documented here. \arguments{ \item{x}{ ~~Describe \code{x} here~~ } } \details{ ~~ If necessary, more details than the description above ~~ } \value{ ~Describe the value returned If it is a LIST, use \item{comp1 }{Description of 'comp1'} \item{comp2 }{Description of 'comp2'} ... } \references{ ~put references to the literature/web site here ~ } \author{ ~~who you are~~ } \note{ ~~further notes~~ ~Make other sections ~ } \seealso{ ~~objects to See Also as \code{\link{help}}, ~~~ } \examples{ ##---- Should be DIRECTLY executable !! ---- ##-- ==> Define data, use random, ##-- or do help(data=index) for the standard data sets. ## The function is currently defined as function(x) { .Call('xtsIs', x) } } % Add one or more standard keywords, see file 'KEYWORDS' in the % R documentation directory. \keyword{ misc } xts/inst/api_example/man/linkXTS-package.Rd0000644000176200001440000000204713463273734020337 0ustar liggesusers\name{linkXTS-package} \alias{linkXTS-package} \alias{linkXTS} \docType{package} \title{ What the package does (short line) ~~ package title ~~ } \description{ More about what it does (maybe more than one line) ~~ A concise (1-5 lines) description of the package ~~ } \details{ \tabular{ll}{ Package: \tab linkXTS\cr Type: \tab Package\cr Version: \tab 1.0\cr Date: \tab 2008-11-12\cr License: \tab What license is it under?\cr LazyLoad: \tab yes\cr } ~~ An overview of how to use the package, including the most important ~~ ~~ functions ~~ } \author{ Who wrote it Maintainer: Who to complain to ~~ The author and/or maintainer of the package ~~ } \references{ ~~ Literature or other references for background information ~~ ~~ Optionally other standard keywords, one per line, from file KEYWORDS in ~~ ~~ the R documentation directory ~~ } \keyword{ package } \seealso{ ~~ Optional links to other man pages, e.g. ~~ ~~ \code{\link[:-package]{}} ~~ } \examples{ #~~ simple examples of the most important functions ~~ } xts/inst/api_example/DESCRIPTION0000644000176200001440000000044313463273734016054 0ustar liggesusersPackage: linkXTS Type: Package Title: Tests the interface to xts.so Version: 1.0 Date: 2008-11-12 Depends: xts LinkingTo: xts Author: Jeffrey A. Ryan Maintainer: Jeffrey A. Ryan Description: Demonstrates LinkingTo C code in packages License: GPL (>= 2) LazyLoad: yes xts/inst/api_example/src/0000755000176200001440000000000013463273734015134 5ustar liggesusersxts/inst/api_example/src/checkOrder.c0000644000176200001440000000125313463273734017352 0ustar liggesusers/* Example of using the C API from xts in new package code This is derived from examining the source of packages Matrix and lme4. */ #include #include #include #include /* required by R */ /* The following header file is from the include directory that is included with xts */ #include "xtsAPI.h" /* function declaration and macros */ SEXP check_order (SEXP x, SEXP incr, SEXP strict) { SEXP ret; PROTECT(ret = allocVector(LGLSXP, 1)); /* do_is_ordered is imported from the xts package. All that is needed here is to call it. */ ret = xtsIsOrdered(x, incr, strict); UNPROTECT(1); return ret; } xts/inst/api_example/R/0000755000176200001440000000000012473475737014555 5ustar liggesusersxts/inst/api_example/R/checkOrder.R0000644000176200001440000000015512473475737016752 0ustar liggesusers# R function to call your compiled code checkOrder <- function(x) { .Call('check_order', x, TRUE, TRUE) } xts/inst/unitTests/0000755000176200001440000000000013607332267014060 5ustar liggesusersxts/inst/unitTests/runit.tzone.R0000644000176200001440000000366213564762102016506 0ustar liggesusers# These tests check the timezone attribute is attached to the expected # component of the xts object. The xts constructors should no longer add # 'tzone' or '.indexTZ' attributes to the xts object itself. Only the index # should have a 'tzone' attribute. Construct xts objects using structure() to # test behavior when functions encounter xts objects created before 0.10-3. x <- structure(1:5, .Dim = c(5L, 1L), index = structure(1:5, tzone = "", tclass = c("POSIXct", "POSIXt")), .indexCLASS = c("POSIXct", "POSIXt"), tclass = c("POSIXct", "POSIXt"), .indexTZ = "UTC", tzone = "UTC", class = c("xts", "zoo")) test.get_tzone <- function() { checkIdentical(tzone(x), "") } test.get_indexTZ_warns <- function() { op <- options(warn = 2) on.exit(options(warn = op$warn)) checkException(indexTZ(x)) } test.set_indexTZ_warns <- function() { op <- options(warn = 2) on.exit(options(warn = op$warn)) checkException(indexTZ(x) <- "GMT") } test.set_tzone_drops_xts_tzone_indexTZ <- function() { y <- x tzone(y) <- "GMT" checkIdentical(NULL, attr(y, "tzone")) checkIdentical(NULL, attr(y, ".indexTZ")) } test.set_tzone_changes_index_tzone <- function() { y <- x tzone(y) <- "GMT" checkIdentical("GMT", attr(attr(y, "index"), "tzone")) } test.set_tzone_to_NULL_sets_empty_string <- function() { y <- x tzone(y) <- NULL checkIdentical("", attr(attr(y, "index"), "tzone")) } test.get_coredata_drops_xts_tzone_indexTZ <- function() { y <- coredata(x) checkIdentical(NULL, attr(y, "tzone")) checkIdentical(NULL, attr(y, ".indexTZ")) } test.get_xtsAttributes_excludes_tzone_indexTZ <- function() { y <- xtsAttributes(x) checkIdentical(NULL, y$tzone) checkIdentical(NULL, y$.indexTZ) } test.set_xtsAttributes_removes_tzone_indexTZ <- function() { y <- x xtsAttributes(y) <- xtsAttributes(x) checkIdentical(NULL, attr(y, "tzone")) checkIdentical(NULL, attr(y, ".indexTZ")) } xts/inst/unitTests/runit.isordered.R0000644000176200001440000000526013564762102017323 0ustar liggesusers# Tests for isOrdered() # # Utility functions for tests {{{ run.isOrdered <- function(x) { c(isOrdered(x, TRUE, TRUE), isOrdered(x, TRUE, FALSE), isOrdered(x, FALSE, FALSE), isOrdered(x, FALSE, TRUE)) } check.isOrdered <- function(x, v = rep(TRUE, 4)) { xc <- paste(capture.output(dput(x)), collapse = " ") checkIdentical(v[1], isOrdered(x, TRUE, TRUE), paste(xc, v[1], "increasing, strictly")) checkIdentical(v[2], isOrdered(x, TRUE, FALSE), paste(xc, v[2], "increasing")) checkIdentical(v[3], isOrdered(x, FALSE, FALSE), paste(xc, v[3], "decreasing")) checkIdentical(v[4], isOrdered(x, FALSE, TRUE), paste(xc, v[4], "decreasing, strictly")) } # }}} TTTT <- rep(TRUE, 4) FFFF <- !TTTT TTFF <- c(TRUE, TRUE, FALSE, FALSE) FFTT <- !TTFF # Increasing {{{ test.isOrdered_incr <- function() { check.isOrdered(1:3, TTFF) check.isOrdered(-1:1, TTFF) check.isOrdered(c(1, 2, 3), TTFF) check.isOrdered(c(-1, 0, 1), TTFF) } ### NA, NaN, Inf # beg test.isOrdered_incr_begNA <- function() { check.isOrdered(c(NA_integer_, 1L, 2L), FFFF) check.isOrdered(c(NA_real_, 1, 2), TTFF) check.isOrdered(c(NaN, 1, 2), TTFF) check.isOrdered(c(Inf, 1, 2), FFFF) check.isOrdered(c(-Inf, 1, 2), TTFF) } # mid test.isOrdered_incr_midNA <- function() { check.isOrdered(c(1L, NA_integer_, 2L), FFFF) check.isOrdered(c(1, NA_real_, 2), TTTT) check.isOrdered(c(1, NaN, 2), TTTT) check.isOrdered(c(1, Inf, 2), FFFF) check.isOrdered(c(1, -Inf, 2), FFFF) } # end test.isOrdered_incr_endNA <- function() { check.isOrdered(c(1L, 2L, NA_integer_), TTFF) check.isOrdered(c(1, 2, NA_real_), TTFF) check.isOrdered(c(1, 2, NaN), TTFF) check.isOrdered(c(1, 2, Inf), TTFF) check.isOrdered(c(1, 2, -Inf), FFFF) } ### # }}} # Decreasing {{{ test.isOrdered_decr <- function() { check.isOrdered(1:-1, FFTT) check.isOrdered(3:1, FFTT) check.isOrdered(c(3, 2, 1), FFTT) check.isOrdered(c(1, 0, -1), FFTT) } ### NA, NaN, Inf # beg test.isOrdered_decr_begNA <- function() { check.isOrdered(c(NA_integer_, 2L, 1L), FFTT) check.isOrdered(c(NA_real_, 2, 1), FFTT) check.isOrdered(c(NaN, 2, 1), FFTT) check.isOrdered(c(Inf, 2, 1), FFTT) check.isOrdered(c(-Inf, 2, 1), FFFF) } # mid test.isOrdered_decr_midNA <- function() { check.isOrdered(c(2L, NA_integer_, 1L), FFFF) check.isOrdered(c(2, NA_real_, 1), TTTT) check.isOrdered(c(2, NaN, 1), TTTT) check.isOrdered(c(2, Inf, 1), FFFF) check.isOrdered(c(2, -Inf, 1), FFFF) } # end test.isOrdered_decr_endNA <- function() { check.isOrdered(c(2L, 1L, NA_integer_), FFFF) check.isOrdered(c(2, 1, NA_real_), FFTT) check.isOrdered(c(2, 1, NaN), FFTT) check.isOrdered(c(2, 1, Inf), FFFF) check.isOrdered(c(2, 1, -Inf), FFTT) } ### # }}} xts/inst/unitTests/runit.merge.R0000644000176200001440000000750313564762102016444 0ustar liggesuserstest.merge_empty_xts_with_2_scalars <- function() { m1 <- merge(xts(), 1, 1) m2 <- merge(merge(xts(), 1), 1) checkIdentical(m1, m2) } test.merge_more_than_2_zero_width_objects <- function() { zw1 <- xts() zw2 <- xts() zw3 <- xts() m1 <- merge(zw1, zw2, zw3) checkIdentical(m1, zw1) } # Tests for NA in index. Construct xts object using structure() because # xts constructors should not allow users to create objects with NA in # the index indexHasNA_dbl <- structure(1:5, .Dim = c(5L, 1L), index = structure(c(1, 2, 3, 4, NA), tzone = "", tclass = c("POSIXct", "POSIXt")), .indexCLASS = c("POSIXct", "POSIXt"), .indexTZ = "", tclass = c("POSIXct", "POSIXt"), tzone = "", class = c("xts", "zoo")) indexHasNA_int <- structure(1:5, .Dim = c(5L, 1L), index = structure(c(1L, 2L, 3L, 4L, NA), tzone = "", tclass = c("POSIXct", "POSIXt")), .indexCLASS = c("POSIXct", "POSIXt"), .indexTZ = "", tclass = c("POSIXct", "POSIXt"), tzone = "", class = c("xts", "zoo")) test.merge_index_contains_NA_integer <- function() { checkException(merge(indexHasNA_int, indexHasNA_int), silent = TRUE) } test.merge_index_contains_NA_double <- function() { checkException(merge(indexHasNA_dbl, indexHasNA_dbl), silent = TRUE) } test.merge_index_contains_NaN <- function() { x <- indexHasNA_dbl idx <- attr(x, "index") idx[length(idx)] <- NaN attr(x, "index") <- idx checkException(merge(x, x), silent = TRUE) } test.merge_index_contains_Inf <- function() { x <- indexHasNA_dbl idx <- attr(x, "index") idx[length(idx)] <- Inf attr(x, "index") <- idx checkException(merge(x, x), silent = TRUE) idx <- rev(idx) idx[1L] <- -Inf attr(x, "index") <- idx checkException(merge(x, x), silent = TRUE) } # /end Tests for NA in index # zero-length fill argument test.merge_fill_NULL <- function() { x1 <- .xts(1, 1) x2 <- .xts(2, 2) x <- merge(x1, x2, fill = NULL) out <- .xts(matrix(c(1, NA, NA, 2), 2), c(1,2)) colnames(out) <- c("x1", "x2") checkIdentical(x, out) } test.merge_fill_zero_length <- function() { x1 <- .xts(1, 1) x2 <- .xts(2, 2) x <- merge(x1, x2, fill = numeric()) out <- .xts(matrix(c(1, NA, NA, 2), 2), c(1,2)) colnames(out) <- c("x1", "x2") checkIdentical(x, out) } test.merge_with_zero_width_returns_original_type <- function() { M1 <- .xts(1:3, 1:3, dimnames = list(NULL, "m1")) for (m in c("double", "integer", "logical", "character")) { m1 <- M1 storage.mode(m1) <- m e1 <- .xts(,1:3) m2 <- merge(m1, e1) checkIdentical(m1, m2) } } test.n_way_merge_on_all_types <- function() { D1 <- as.Date("2018-01-03")-2:0 M1 <- xts(1:3, D1, dimnames = list(NULL, "m")) M3 <- xts(cbind(1:3, 1:3, 1:3), D1, dimnames = list(NULL, c("m", "m.1", "m.2"))) types <- c("double", "integer", "logical", "character", "complex") for (type in types) { m1 <- M1 m3 <- M3 storage.mode(m1) <- storage.mode(m3) <- type m <- merge(m1, m1, m1) checkIdentical(m, m3) } } test.shorter_colnames_for_unnamed_args <- function() { X <- .xts(rnorm(10, 10), 1:10) types <- c("double", "integer", "logical", "character", "complex") for (type in types) { x <- X storage.mode(x) <- type mx <- do.call(merge, list(x, x)) checkTrue(all(nchar(colnames(mx)) < 200), type) } } test.check_names_false <- function() { x <- .xts(1:3, 1:3, dimnames = list(NULL, "42")) y <- .xts(1:3, 1:3, dimnames = list(NULL, "21")) z <- merge(x, y) # leading "X" added checkIdentical(colnames(z), c("X42", "X21")) z <- merge(x, y, check.names = TRUE) # same checkIdentical(colnames(z), c("X42", "X21")) z <- merge(x, y, check.names = FALSE) # should have numeric column names checkIdentical(colnames(z), c("42", "21")) } xts/inst/unitTests/runit.xts.methods.R0000644000176200001440000002316013564762102017622 0ustar liggesusers# # RUnit tests for the following 'xts' methods: # rbind # cbind # test.rbind_zero_length_non_zero_length_POSIXct_errors <- function() { xpz <- xts( , as.POSIXct("2017-01-01")) xp1 <- xts(1, as.POSIXct("2017-01-02")) zpz <- as.zoo(xpz) zp1 <- as.zoo(xp1) zpe <- tryCatch(rbind(zpz, zp1), error = identity) xpe <- tryCatch(rbind(xpz, xp1), error = identity) checkIdentical(zpe$message, xpe$message) } test.rbind_zero_length_non_zero_length_Date_errors <- function() { xpz <- xts( , as.Date("2017-01-01")) xp1 <- xts(1, as.Date("2017-01-02")) zpz <- as.zoo(xpz) zp1 <- as.zoo(xp1) zpe <- tryCatch(rbind(zpz, zp1), error = identity) xpe <- tryCatch(rbind(xpz, xp1), error = identity) checkIdentical(zpe$message, xpe$message) } # Test that as.Date.numeric() works at the top level (via zoo::as.Date()), # and for functions defined in the xts namespace even if xts::as.Date.numeric() # is not formally registered as an S3 method. test.as.Date.numeric <- function() { # Define function that calls as.Date.numeric() ... f <- function(d) { as.Date(d) } # ... in xts' namespace environment(f) <- as.environment("package:xts") dd <- as.Date("2017-12-13") dn <- unclass(dd) checkIdentical(dd, as.Date(dn)) # via zoo::as.Date() checkIdentical(dd, f(dn)) } # .subset.xts # window.xts # .toPOSIXct (indirectly) test.window <- function() { # window function for xts series, use basic logic for testing & debugging # null start and end not supported window_dbg <- function(x, index. = index(x), start, end) { start <- xts:::.toPOSIXct(start, indexTZ(x)) end <- xts:::.toPOSIXct(end, indexTZ(x)) index. <- as.POSIXct(index., tz=indexTZ(x)) all.indexes <- .index(x) in.index <- all.indexes %in% index. matches <- (in.index & all.indexes >= start & all.indexes <= end) x[matches,] } DAY = 24*3600 base <- as.POSIXct("2000-12-31") dts <- base + c(1:10, 12:15, 17:20)*DAY x <- xts(1:length(dts), dts) # Range over gap start <- base + 11*DAY end <- base + 16*DAY bin <- window(x, start = start, end = end) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Range over gap") # Range over one day start <- base + 12*DAY end <- base + 12*DAY bin <- window(x, start = start, end = end) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Range over one day") # Empty Range over one day start <- base + 11*DAY end <- base + 11*DAY bin <- window(x, start = start, end = end) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Empty Range over one day") # Range containing all dates start <- base end <- base + 21*DAY bin <- window(x, start = start, end = end) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Range containing all dates") # Range past end start <- base + 16*DAY end <- base + 30*DAY bin <- window(x, start = start, end = end) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Range past end") # Range before begin start <- base end <- base + 3*DAY bin <- window(x, start = start, end = end) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Range before begin") # Test just start, end = NULL start <- base + 13 * DAY end <- base + 30*DAY bin <- window(x, start = start) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Test just start, end = NULL") # Test just start, end = NULL, empty range start <- base + 25 * DAY end <- base + 30*DAY bin <- window(x, start = start) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Test just start, end = NULL, empty range") # Test just end, start = NULL end <- base + 13 * DAY start <- base bin <- window(x, end = end) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Test just end, start = NULL") # Test just end, start = NULL, empty range end <- base start <- base bin <- window(x, end = end) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Test just end, start = NULL, empty range") # Test end = NULL, start = NULL start <- base end <- base + 30*DAY bin <- window(x) reg <- window_dbg(x, start = start, end = end) checkIdentical(bin, reg, "Test end = NULL, start = NULL") ####################################### # Test for index. parameter start <- base end <- base + 30*DAY idx = index(x)[c(2,4,6)] bin <- window(x, index. = idx) reg <- window_dbg(x, index. = idx, start = start, end = end) checkIdentical(bin, reg, "Test for index. parameter") # Test index. outside range of dates in xts series start <- base end <- base + 30*DAY idx = c(start, index(x)[c(2,4,6)], end) bin <- window(x, index. = idx) reg <- window_dbg(x, index. = idx, start = start, end = end) checkIdentical(bin, reg, "Test index. outside range of dates in xts series") # Test NA in index start <- base end <- base + 30*DAY idx = c(start, index(x)[c(2,4,6)], end, NA) bin <- window(x, index. = idx) reg <- window_dbg(x, index. = idx, start = start, end = end) checkIdentical(bin, reg, "Test NA in index ") # Next 3 adapted from window.zoo example # Test basic window.zoo example x.date <- as.Date(paste(2003, rep(1:4, 4:1), seq(1,19,2), sep = "-")) x <- xts(matrix(1:20, ncol = 2), x.date) bin <- window(x, start = as.Date("2003-02-01"), end = as.Date("2003-03-01")) reg <- window_dbg(x, start = as.Date("2003-02-01"), end = as.Date("2003-03-01")) checkIdentical(bin, reg, "Test basic window.zoo example") # Test index + start bin <- window(x, index = x.date[1:6], start = as.Date("2003-02-01")) reg <- window_dbg(x, index = x.date[1:6], start = as.Date("2003-02-01"), end = as.Date("2004-01-01")) checkIdentical(bin, reg, "Test index + start") # Test just index bin <- window(x, index = x.date[c(4, 8, 10)]) reg <- window_dbg(x, index = x.date[c(4, 8, 10)], start = as.Date("2003-01-01"), end = as.Date("2004-01-01")) checkIdentical(bin, reg, "Test just index") # Test decreasing index bin <- window(x, index = x.date[c(10, 8, 4)]) reg <- window_dbg(x, index = x.date[c(10, 8, 4)], start = as.Date("2003-01-01"), end = as.Date("2004-01-01")) checkIdentical(bin, reg, "Test decreasing index") # Test index parameter with repeated dates in xts series idx <- sort(rep(1:5, 5)) x <- xts(1:length(idx), as.Date("1999-12-31")+idx) bin <- window(x, index = as.Date("1999-12-31")+c(1,3,5)) reg <- window_dbg(x, index = as.Date("1999-12-31")+c(1,3,5), start = as.Date("2000-01-01"), end = as.Date("2000-01-05")) checkIdentical(bin, reg, "Test index parameter with repeated dates in xts series") checkTrue(nrow(bin) == 3*5, "Test index parameter with repeated dates in xts series") # Test performance difference DAY = 24*3600 base <- as.POSIXct("2000-12-31") dts <- base + c(1:10, 12:15, 17:20)*DAY x <- xts(1:length(dts), dts) start <- base + 14*DAY end <- base + 14*DAY cat("\n") print("performance:") print("binary search") print(system.time(replicate(1000, window(x, start = start, end = end)))) # Binary search is about 2x faster than regular print("regular search") print(system.time(replicate(1000, window_dbg(x, start = start, end = end)))) } # test subset.xts for date subsetting by row test.subset_i_datetime_or_character <- function() { base <- as.POSIXct("2000-12-31") dts <- base + c(1:10, 12:15, 17:20) * 24L * 3600L x <- xts(seq_along(dts), dts) # Note that "2001-01-11" is not in the series. Skipped by convention. d <- c("2001-01-10", "2001-01-11", "2001-01-12", "2001-01-13") for (type in c("double", "integer")) { storage.mode(.index(x)) <- type # Test scalar msg <- paste("scalar,", type, "index") bin <- window(x, start = d[1], end = d[1]) checkIdentical(bin, x[d[1], ], paste("character", msg)) checkIdentical(bin, x[I(d[1]), ], paste("as-is character", msg)) checkIdentical(bin, x[as.POSIXct(d[1]), ], paste("POSIXct", msg)) checkIdentical(bin, x[as.Date(d[1]), ], paste("Date", msg)) # Test vector msg <- paste("vector,", type, "index") bin <- window(x, start = d[1], end = d[length(d)]) checkIdentical(bin, x[d, ], paste("character", msg)) checkIdentical(bin, x[I(d), ], paste("as-is character", msg)) checkIdentical(bin, x[as.POSIXct(d), ], paste("POSIXct", msg)) checkIdentical(bin, x[as.Date(d), ], paste("Date", msg)) # Test character dates, and single column selection y <- xts(rep(2, length(dts)), dts) z <- xts(rep(3, length(dts)), dts) x2 <- cbind(y, x, z) sub <- x2[d, 2] # Note that "2001-01-11" is not in the series. Skipped by convention. bin <- window(x, start = d[1], end = d[length(d)]) checkTrue(nrow(sub) == nrow(bin), "Test character dates, and single column selection") checkTrue(all(sub == bin), "Test character dates, and single column selection") } } test.subset_i_ISO8601 <- function() { x <- xts(1:1000, as.Date("2000-01-01")+1:1000) for (type in c("double", "integer")) { storage.mode(.index(x)) <- type fmt <- paste("Test date range, %s;", type, "index") # Test Date Ranges sub <- x['200001'] # January 2000 bin <- window(x, start = "2000-01-01", end = "2000-01-31") checkIdentical(bin, sub, sprintf(fmt, "2000-01")) # Test Date Ranges 2 sub <- x['1999/2000'] # All of 2000 (note there is no need to use the exact start) bin <- window(x, start = "2000-01-01", end = "2000-12-31") checkIdentical(bin, sub, sprintf(fmt, "1999/2000")) # Test Date Ranges 3 sub <- x['1999/200001'] # January 2000 bin <- window(x, start = "2000-01-01", end = "2000-01-31") checkIdentical(bin, sub, sprintf(fmt, "1999/2000-01")) } } xts/inst/unitTests/runit.plot.R0000644000176200001440000000172413564762102016322 0ustar liggesusers# Tests for plotting functions data(sample_matrix) x <- as.xts(sample_matrix, dateFormat = "Date") # axTicksByTime test.format_xts_yearqtr <- function() { xq <- to.quarterly(x) xtbt <- axTicksByTime(xq) checkIdentical(names(xtbt), c("2007-Q1", "2007-Q2")) } test.format_zoo_yearqtr <- function() { xq <- to.quarterly(x) xtbt <- axTicksByTime(as.zoo(xq)) checkIdentical(names(xtbt), c("2007-Q1", "2007-Q2")) } test.axTicksByTime_ticks.on_quarter <- function() { tick_marks <- setNames(c(1, 4, 7, 10, 13, 16, 19, 22, 25, 25), c("\nJan\n2016", "\nApr\n2016", "\nJul\n2016", "\nOct\n2016", "\nJan\n2017", "\nApr\n2017", "\nJul\n2017", "\nOct\n2017", "\nJan\n2018", "\nJan\n2018")) if (.Platform$OS.type != "unix") { names(tick_marks) <- gsub("\n(.*)\n", "\\1 ", names(tick_marks)) } ym <- as.yearmon("2018-01") - 24:0 / 12 x <- xts(seq_along(ym), ym) xtbt <- axTicksByTime(x, ticks.on = "quarters") checkIdentical(xtbt, tick_marks) } xts/inst/unitTests/runit.na.omit.R0000644000176200001440000000212713564762102016707 0ustar liggesusersXDAT <- .xts(c(1, NA, 3, 4, 5, 6), c(0, 4, 10, 19, 24, 29)) XIDX <- .xts(rep(0, 5), c(5, 10, 20, 25, 28)) MODES <- c("double", "integer", "character", "logical") test.naomit <- function() { for (m in MODES) { xdat <- XDAT xidx <- XIDX storage.mode(xdat) <- storage.mode(xidx) <- m zdat <- as.zoo(xdat) zidx <- as.zoo(xidx) x <- na.omit(xdat) z <- na.omit(zdat) # na.omit.xts adds "index" attribute to the "na.action" attribute attr(attr(x, "na.action"), "index") <- NULL #checkIdentical(x, as.xts(z)) # FALSE (attribute order differs) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.naomit_by_column <- function() { for (m in MODES) { xdat <- XDAT xidx <- XIDX storage.mode(xdat) <- storage.mode(xidx) <- m zdat <- as.zoo(xdat) zidx <- as.zoo(xidx) x <- na.omit(merge(one = xdat, two = xdat)) z <- na.omit(merge(one = zdat, two = zdat)) # na.omit.xts adds "index" attribute to the "na.action" attribute attr(attr(x, "na.action"), "index") <- NULL checkEquals(x, as.xts(z), check.attributes = TRUE) } } xts/inst/unitTests/runit.binsearch.R0000644000176200001440000000635613564762102017310 0ustar liggesusersna <- NA_integer_ # vector with even length, odd length # no/yes result (potential infinite loop) # https://www.topcoder.com/community/data-science/data-science-tutorials/binary-search/ test.integer_predicate_no_yes_stops <- function() { ans <- 2L ivec <- 3:4 ikey <- ivec[ans] checkIdentical(ans, xts:::binsearch(ikey, ivec, TRUE)) checkIdentical(ans, xts:::binsearch(ikey, ivec, FALSE)) } # small steps between vector elements (test that we actually stop) test.double_with_small_delta_stops <- function() { ans <- 10L dvec <- 1 + (-10:10 / 1e8) dkey <- dvec[ans] checkIdentical(ans, xts:::binsearch(dkey, dvec, TRUE)) checkIdentical(ans, xts:::binsearch(dkey, dvec, FALSE)) } test.find_first_zero_even_length <- function() { ivec <- sort(c(0L, -3:5L)) dvec <- ivec * 1.0 checkIdentical(4L, xts:::binsearch(0L, ivec, TRUE)) checkIdentical(4L, xts:::binsearch(0.0, dvec, TRUE)) } test.find_last_zero_even_length <- function() { ivec <- sort(c(0L, -3:5L)) dvec <- ivec * 1.0 checkIdentical(5L, xts:::binsearch(0L, ivec, FALSE)) checkIdentical(5L, xts:::binsearch(0.0, dvec, FALSE)) } test.find_first_zero_odd_length <- function() { ivec <- sort(c(0L, -3:5L)) dvec <- ivec * 1.0 checkIdentical(4L, xts:::binsearch(0L, ivec, TRUE)) checkIdentical(4L, xts:::binsearch(0.0, dvec, TRUE)) } test.find_last_zero_odd_length <- function() { ivec <- sort(c(0L, -3:5L)) dvec <- ivec * 1.0 checkIdentical(5L, xts:::binsearch(0L, ivec, FALSE)) checkIdentical(5L, xts:::binsearch(0.0, dvec, FALSE)) } # key is outside of vector test.key_less_than_min <- function() { ivec <- 1:6 checkIdentical(1L, xts:::binsearch(-9L, ivec, TRUE)) checkIdentical(na, xts:::binsearch(-9L, ivec, FALSE)) dvec <- ivec * 1.0 checkIdentical(1L, xts:::binsearch(-9, dvec, TRUE)) checkIdentical(na, xts:::binsearch(-9, dvec, FALSE)) } test.key_greater_than_max <- function() { ivec <- 1:6 checkIdentical(na, xts:::binsearch( 9L, ivec, TRUE)) checkIdentical(6L, xts:::binsearch( 9L, ivec, FALSE)) dvec <- ivec * 1.0 checkIdentical(na, xts:::binsearch( 9, dvec, TRUE)) checkIdentical(6L, xts:::binsearch( 9, dvec, FALSE)) } # key is NA test.key_is_NA <- function() { ivec <- 1:6 ikey <- NA_integer_ checkIdentical(na, xts:::binsearch(ikey, ivec, TRUE)) checkIdentical(na, xts:::binsearch(ikey, ivec, FALSE)) dvec <- ivec * 1.0 dkey <- NA_real_ checkIdentical(na, xts:::binsearch(dkey, dvec, TRUE)) checkIdentical(na, xts:::binsearch(dkey, dvec, FALSE)) } # key is zero-length test.key_is_zero_length <- function() { # have empty key return NA ivec <- 1:6 ikey <- integer() checkIdentical(na, xts:::binsearch(ikey, ivec, TRUE)) checkIdentical(na, xts:::binsearch(ikey, ivec, FALSE)) dvec <- ivec * 1.0 dkey <- double() checkIdentical(na, xts:::binsearch(dkey, dvec, TRUE)) checkIdentical(na, xts:::binsearch(dkey, dvec, FALSE)) } # vec is zero-length test.vec_is_zero_length <- function() { # have empty vector return NA ivec <- integer() ikey <- 0L checkIdentical(na, xts:::binsearch(ikey, ivec, TRUE)) checkIdentical(na, xts:::binsearch(ikey, ivec, FALSE)) dvec <- double() dkey <- 0.0 checkIdentical(na, xts:::binsearch(dkey, dvec, TRUE)) checkIdentical(na, xts:::binsearch(dkey, dvec, FALSE)) } xts/inst/unitTests/runit.subset.R0000644000176200001440000002246713564762102016660 0ustar liggesusers# i = missing, j = NA, object has column names # See #181 test.i_missing_j_NA_has_colnames <- function() { iina <- .xts(matrix(NA_integer_, 5, 2), 1:5) idna <- .xts(matrix(NA_integer_, 5, 2), 1.0 * 1:5) dina <- .xts(matrix(NA_real_, 5, 2), 1:5) ddna <- .xts(matrix(NA_real_, 5, 2), 1.0 * 1:5) colnames(iina) <- colnames(idna) <- colnames(dina) <- colnames(ddna) <- rep(NA_character_, 2) # int data, int index ii <- .xts(matrix(1:10, 5, 2), 1:5) colnames(ii) <- c("a", "b") checkIdentical(ii[, NA], iina) checkIdentical(ii[, 1][, NA], iina[, 1]) # int data, dbl index id <- .xts(matrix(1:10, 5, 2), 1.0 * 1:5) colnames(id) <- c("a", "b") checkIdentical(id[, NA], idna) checkIdentical(id[, 1][, NA], idna[, 1]) # dbl data, int index di <- .xts(1.0 * matrix(1:10, 5, 2), 1:5) colnames(di) <- c("a", "b") checkIdentical(di[, NA], dina) checkIdentical(di[, 1][, NA], dina[, 1]) # dbl data, dbl index dd <- .xts(1.0 * matrix(1:10, 5, 2), 1.0 * 1:5) colnames(dd) <- c("a", "b") checkIdentical(dd[, NA], ddna) checkIdentical(dd[, 1][, NA], ddna[, 1]) } # i = missing, j = NA, object does not have column names # See #97 test.i_missing_j_NA_no_colnames <- function() { iina <- .xts(matrix(NA_integer_, 5, 2), 1:5) idna <- .xts(matrix(NA_integer_, 5, 2), 1.0 * 1:5) dina <- .xts(matrix(NA_real_, 5, 2), 1:5) ddna <- .xts(matrix(NA_real_, 5, 2), 1.0 * 1:5) # int data, int index ii <- .xts(matrix(1:10, 5, 2), 1:5) checkIdentical(ii[, NA], iina) checkIdentical(ii[, 1][, NA], iina[, 1]) # int data, dbl index id <- .xts(matrix(1:10, 5, 2), 1.0 * 1:5) checkIdentical(id[, NA], idna) checkIdentical(id[, 1][, NA], idna[, 1]) # dbl data, int index di <- .xts(1.0 * matrix(1:10, 5, 2), 1:5) checkIdentical(di[, NA], dina) checkIdentical(di[, 1][, NA], dina[, 1]) # dbl data, dbl index dd <- .xts(1.0 * matrix(1:10, 5, 2), 1.0 * 1:5) checkIdentical(dd[, NA], ddna) checkIdentical(dd[, 1][, NA], ddna[, 1]) } # i = integer, j = NA, object has column names # See #97 test.i_integer_j_NA_has_colnames <- function() { iina <- .xts(matrix(NA_integer_, 5, 2), 1:5) idna <- .xts(matrix(NA_integer_, 5, 2), 1.0 * 1:5) dina <- .xts(matrix(NA_real_, 5, 2), 1:5) ddna <- .xts(matrix(NA_real_, 5, 2), 1.0 * 1:5) colnames(iina) <- colnames(idna) <- colnames(dina) <- colnames(ddna) <- rep(NA_character_, 2) i <- 1:3 # int data, int index ii <- .xts(matrix(1:10, 5, 2), 1:5) colnames(ii) <- c("a", "b") checkIdentical(ii[i, NA], iina[i,]) checkIdentical(ii[i, 1][, NA], iina[i, 1]) # int data, dbl index id <- .xts(matrix(1:10, 5, 2), 1.0 * 1:5) colnames(id) <- c("a", "b") checkIdentical(id[i, NA], idna[i,]) checkIdentical(id[i, 1][, NA], idna[i, 1]) # dbl data, int index di <- .xts(1.0 * matrix(1:10, 5, 2), 1:5) colnames(di) <- c("a", "b") checkIdentical(di[i, NA], dina[i,]) checkIdentical(di[i, 1][, NA], dina[i, 1]) # dbl data, dbl index dd <- .xts(1.0 * matrix(1:10, 5, 2), 1.0 * 1:5) colnames(dd) <- c("a", "b") checkIdentical(dd[i, NA], ddna[i,]) checkIdentical(dd[i, 1][, NA], ddna[i, 1]) } # i = integer, j = NA, object does not have column names # See #97 test.i_integer_j_NA_no_colnames <- function() { iina <- .xts(matrix(NA_integer_, 5, 2), 1:5) idna <- .xts(matrix(NA_integer_, 5, 2), 1.0 * 1:5) dina <- .xts(matrix(NA_real_, 5, 2), 1:5) ddna <- .xts(matrix(NA_real_, 5, 2), 1.0 * 1:5) i <- 1:3 # int data, int index ii <- .xts(matrix(1:10, 5, 2), 1:5) checkIdentical(ii[i, NA], iina[i,]) checkIdentical(ii[i, 1][, NA], iina[i, 1]) # int data, dbl index id <- .xts(matrix(1:10, 5, 2), 1.0 * 1:5) checkIdentical(id[i, NA], idna[i,]) checkIdentical(id[i, 1][, NA], idna[i, 1]) # dbl data, int index di <- .xts(1.0 * matrix(1:10, 5, 2), 1:5) checkIdentical(di[i, NA], dina[i,]) checkIdentical(di[i, 1][, NA], dina[i, 1]) # dbl data, dbl index dd <- .xts(1.0 * matrix(1:10, 5, 2), 1.0 * 1:5) checkIdentical(dd[i, NA], ddna[i,]) checkIdentical(dd[i, 1][, NA], ddna[i, 1]) } test.i_0 <- function() { x <- .xts(matrix(1:10, 5, 2), 1:5) z <- as.zoo(x) xz0 <- as.xts(z[0,]) checkEquals(x[0,], xz0, check.attributes = TRUE) } # Subset by non-numeric classes X <- xts(1:5, as.Date("2018-04-21") - 5:1) test.i_character <- function() { x <- X for (r in c(1L, 3L, 5L)) { y <- x[r,] i <- as.character(index(y)) checkIdentical(y, x[i, ]) } } test.i_asis_character <- function() { x <- X for (r in c(1L, 3L, 5L)) { y <- x[r,] i <- as.character(index(y)) checkIdentical(y, x[I(i), ]) } } test.i_Date <- function() { x <- X for (r in c(1L, 3L, 5L)) { y <- x[r,] i <- index(y) checkIdentical(y, x[i, ]) } } test.i_POSIXct <- function() { x <- X index(x) <- as.POSIXct(index(x), tz = "UTC") for (r in c(1L, 3L, 5L)) { y <- x[r,] i <- index(y) checkIdentical(y, x[i, ]) } } test.i_POSIXlt <- function() { x <- X index(x) <- as.POSIXlt(index(x), tz = "UTC") for (r in c(1L, 3L, 5L)) { y <- x[r,] i <- index(y) checkIdentical(y, x[i, ]) } } # invalid date/time test.i_invalid_date_string <- function() { x <- xts(1:10, as.Date("2015-02-20")+0:9) y <- x["2012-02-30"] checkIdentical(y, x[NA,]) } test.i_only_range_separator_or_empty_string <- function() { x <- xts(1:10, as.Date("2015-02-20")+0:9) y <- x["/",] checkIdentical(y, x) y <- x["::",] checkIdentical(y, x) y <- x["",] checkIdentical(y, x) } test.i_date_range_open_end <- function() { x <- xts(1:10, as.Date("2015-02-20")+0:9) y <- x["2015-02-23/",] checkIdentical(y, x[4:10,]) } test.i_date_range_open_start <- function() { x <- xts(1:10, as.Date("2015-02-20")+0:9) y <- x["/2015-02-26",] checkIdentical(y, x[1:7,]) } # subset empty xts test.empty_i_datetime <- function() { d0 <- as.Date(integer()) zl <- xts(, d0) empty <- .xts(logical(), d0, dim = 0:1, dimnames = list(NULL, NULL)) i <- Sys.Date() checkIdentical(zl[i,], empty) checkIdentical(zl[i], empty) i <- Sys.time() checkIdentical(zl[i,], empty) checkIdentical(zl[i], empty) } test.empty_i_zero <- function() { d0 <- as.Date(integer()) zl <- xts(, d0) empty <- .xts(logical(), d0, dim = 0:1, dimnames = list(NULL, NULL)) checkIdentical(zl[0,], empty) checkIdentical(zl[0], empty) } test.empty_i_negative <- function() { d0 <- as.Date(integer()) zl <- xts(, d0) empty <- .xts(logical(), d0, dim = 0:1, dimnames = list(NULL, NULL)) checkIdentical(zl[-1,], empty) checkIdentical(zl[-1], empty) } test.empty_i_NA <- function() { d0 <- as.Date(integer()) zl <- xts(, d0) empty <- .xts(logical(), d0, dim = 0:1, dimnames = list(NULL, NULL)) checkIdentical(zl[NA,], empty) checkIdentical(zl[NA], empty) } test.empty_i_NULL <- function() { d0 <- as.Date(integer()) zl <- xts(, d0) empty <- .xts(logical(), d0, dim = 0:1, dimnames = list(NULL, NULL)) checkIdentical(zl[NULL,], empty) checkIdentical(zl[NULL], empty) } test.duplicate_index_duplicate_i <- function() { dates <- structure(c(15770, 16257, 16282, 16291, 16296, 16296, 16298, 16301, 16432, 16452), class = "Date") x <- xts(c(1, 2, 2, 3, 3, 3, 3, 3, 4, 4), dates) dupdates <- structure(c(15770, 16257, 16282, 16291, 16296, 16296, 16296, 16296, 16298, 16301, 16432, 16452), class = "Date") y <- xts(c(1, 2, 2, 3, 3, 3, 3, 3, 3, 3, 4, 4), dupdates) checkIdentical(x[index(x),], y) } # Time-of-day subset test.time_of_day_when_DST_starts <- function() { # 2017-03-12: no 0200 tz <- "America/Chicago" tmseq <- seq(as.POSIXct("2017-03-11", tz), as.POSIXct("2017-03-14", tz), by = "1 hour") x <- xts(seq_along(tmseq), tmseq) i <- structure(c(1489215600, 1489219200, 1489222800, 1489302000, 1489305600, 1489384800, 1489388400, 1489392000), tzone = "America/Chicago", tclass = c("POSIXct", "POSIXt")) checkIdentical(.index(x["T01:00:00/T03:00:00"]), i) } test.time_of_day_when_DST_ends <- function() { # 2017-11-05: 0200 occurs twice tz <- "America/Chicago" tmseq <- seq(as.POSIXct("2017-11-04", tz), as.POSIXct("2017-11-07", tz), by = "1 hour") x <- xts(seq_along(tmseq), tmseq) i <- structure(c(1509775200, 1509778800, 1509782400, 1509861600, 1509865200, 1509868800, 1509872400, 1509951600, 1509955200, 1509958800), tzone = "America/Chicago", tclass = c("POSIXct", "POSIXt")) checkIdentical(.index(x["T01:00:00/T03:00:00"]), i) } test.time_of_day_start_equals_end <- function() { i <- 0:47 x <- .xts(i, i * 3600, tz = "UTC") i1 <- .index(x[c(2L, 26L)]) checkIdentical(.index(x["T01:00/T01:00"]), i1) } test.time_of_day_end_before_start <- function() { # Yes, this actually makes sense and is useful for financial markets # E.g. some futures markets open at 18:00 and close at 16:00 the next day i <- 0:47 x <- .xts(i, i * 3600, tz = "UTC") i1 <- .index(x[-c(18L, 42L)]) checkIdentical(.index(x["T18:00/T16:00"]), i1) } # TODO: Add tests for possible edge cases and/or errors # end time before start time # start time and/or end time missing "T" prefix # start time and/or end time missing ":" separator test.time_of_day_on_zero_width <- function() { # return relevant times and a column of NA; consistent with zoo i <- 0:47 tz <- "America/Chicago" x <- .xts(, i * 3600, tzone = tz) y <- x["T18:00/T20:00"] checkIdentical(y, .xts(rep(NA, 6), c(0:2, 24:26)*3600, tzone = tz)) } xts/inst/unitTests/runit.align.time.R0000644000176200001440000000425413564762102017374 0ustar liggesusers# make.index.unique test.make.index.unique_1us_default_eps <- function() { x <- .xts(1:5, rep(1e-6, 5)) y <- make.index.unique(x) checkEqualsNumeric(.index(y), cumsum(rep(1e-6, 5))) } test.make.index.unique_returns_sorted_index <- function() { x <- .xts(1:5, c(rep(1e-6, 4), 3e-6)) y <- make.index.unique(x, eps = 1e-6) checkEqualsNumeric(.index(y), cumsum(rep(1e-6, 5))) } test.make.index.unique_adds_eps_to_duplicates <- function() { epsilon <- c(1e-6, 1e-7, 1e-8) for (eps in epsilon) { x <- .xts(1:5, rep(eps, 5)) y <- make.index.unique(x, eps = eps) checkEqualsNumeric(.index(y), cumsum(rep(eps, 5))) } } test.make.index.unique_no_warn_if_unique_timestamps_unchanged <- function() { x <- .xts(1:10, c(rep(1e-6, 9), 1e-5)) y <- make.index.unique(x, eps = 1e-6) checkEqualsNumeric(.index(y), cumsum(rep(1e-6, 10))) } test.make.index.unique_warns_if_unique_timestamp_changes <- function() { # There should be a warning if the cumulative epsilon for a set of duplicate # index values is larger than the first unique index value that follows. # When this happens, we will overwrite that non-duplicate index value with # the prior index value + eps. eps <- 1e-6 x <- .xts(1:5, c(rep(0, 4), 2*eps)) orig <- options(warn = 2) on.exit(options(warn = orig$warn)) checkException(y <- make.index.unique(x, eps = eps)) } test.make.index.unique_warns_ONCE_if_unique_timestamp_changes <- function() { # There should be a warning if the cumulative epsilon for a set of duplicate # index values is larger than the first unique index value that follows. # When this happens, we will overwrite that non-duplicate index value with # the prior index value + eps. eps <- 1e-6 x <- .xts(1:5, c(rep(0, 3), 2, 3) * eps) count <- 0L withCallingHandlers(make.index.unique(x, eps = eps), warning = function(w) { count <<- count + 1L }) checkEquals(count, 1L) } test.make.index.unique_converts_date_index_to_POSIXct <- function() { # It doesn't make sense to add a small epsilon to a date index. The C code # converts the integer index to a double, but it keeps the same index class. # The index class should be converted to POSIXct. } xts/inst/unitTests/runit.timeSeries.R0000644000176200001440000001066613564762102017462 0ustar liggesusers## ## Unit Test for timeSeries class from Rmetrics timeSeries package ## ## if (requireNamespace("timeSeries", quietly = TRUE)) { data(sample_matrix) ############################################################################### ############################################################################### # # Multivariate timeSeries tests # ############################################################################### ############################################################################### ############################################################################### # create timeSeries object from sample_matrix sample.timeSeries <- timeSeries::timeSeries(sample_matrix,charvec=as.Date(rownames(sample_matrix))) ############################################################################### ############################################################################### # create corresponding 'xts' object sample.xts <- as.xts(sample.timeSeries) ############################################################################### ############################################################################### # test subsetting functionality of xts test.convert_timeSeries_to_xts <- function() { checkIdentical(sample.xts,as.xts(sample.timeSeries)) } test.convert_timeSeries_to_xts_j1 <- function() { checkIdentical(sample.xts[,1],as.xts(sample.timeSeries)[,1]) } test.convert_timeSeries_to_xts_i1 <- function() { checkIdentical(sample.xts[1,],as.xts(sample.timeSeries)[1,]) } test.convert_timeSeries_to_xts_i1j1 <- function() { checkIdentical(sample.xts[1,1],as.xts(sample.timeSeries)[1,1]) } # end subsetting functionality ############################################################################### ############################################################################### # test 'reclass' test.timeSeries_reclass <- function() { checkIdentical(sample.timeSeries,reclass(try.xts(sample.timeSeries))) } test.timeSeries_reclass_subset_reclass_j1 <- function() { checkIdentical(sample.timeSeries[,1],reclass(try.xts(sample.timeSeries))[,1]) } test.timeSeries_reclass_subset_as.xts_j1 <- function() { spl <- sample.timeSeries[,1:2] respl <- reclass(try.xts(sample.timeSeries)[,1:2]) # timeSeries fails to maintain @positions correctly if one column is selected # checkIdentical(spl,respl) checkIdentical(1,1) } test.timeSeries_reclass_subset_timeSeries_j1 <- function() { spl <- sample.timeSeries[,1:2] respl <- reclass(try.xts(sample.timeSeries[,1:2])) # timeSeries fails to maintain @positions correctly if one column is selected # checkIdentical(spl,respl) checkIdentical(1,1) } # end 'reclass' ############################################################################### ############################################################################### ############################################################################### # # Univariate timeSeries tests # ############################################################################### ############################################################################### ############################################################################### # create timeSeries object from sample_matrix sample.timeSeries.univariate <- timeSeries::timeSeries(sample_matrix[,1],charvec=as.Date(rownames(sample_matrix))) ############################################################################### ############################################################################### # create corresponding 'xts' object sample.xts.univariate <- as.xts(sample.timeSeries.univariate) ############################################################################### ############################################################################### # test subsetting functionality of xts test.convert_timeSeries.univariate_to_xts <- function() { checkIdentical(sample.xts.univariate,as.xts(sample.timeSeries.univariate)) } test.convert_timeSeries.univariate_to_xts_j1 <- function() { checkIdentical(sample.xts.univariate[,1],as.xts(sample.timeSeries.univariate)[,1]) } test.convert_timeSeries.univariate_to_xts_i1 <- function() { checkIdentical(sample.xts.univariate[1,],as.xts(sample.timeSeries.univariate)[1,]) } test.convert_timeSeries.univariate_to_xts_i1j1 <- function() { checkIdentical(sample.xts.univariate[1,1],as.xts(sample.timeSeries.univariate)[1,1]) } # end subsetting functionality ############################################################################### } # requireNamespace xts/inst/unitTests/runit.xts.R0000644000176200001440000001755013607330401016155 0ustar liggesusers# Tests for xts constructors # ### NA in order.by {{{ # .xts() test..xts_order.by_NA_integer <- function() { checkException(.xts(1:3, c(1L, 2L, NA))) checkException(.xts(1:3, c(NA, 2L, 3L))) checkException(.xts(1:3, c(1L, NA, 3L))) } test..xts_order.by_NA_double <- function() { checkException(.xts(1:3, c(1, 2, NA))) checkException(.xts(1:3, c(NA, 2, 3))) checkException(.xts(1:3, c(1, NA, 3))) } test..xts_order.by_NaN_double <- function() { checkException(.xts(1:3, c(1, 2, NaN))) checkException(.xts(1:3, c(NaN, 2, 3))) checkException(.xts(1:3, c(1, NaN, 3))) } test..xts_order.by_Inf_double <- function() { checkException(.xts(1:3, c(1, 2, Inf))) checkException(.xts(1:3, c(-Inf, 2, 3))) } # xts() test.xts_order.by_NA_integer <- function() { checkException(xts(1:3, as.Date(c(1L, 2L, NA), origin = "1970-01-01"))) checkException(xts(1:3, as.Date(c(NA, 2L, 3L), origin = "1970-01-01"))) checkException(xts(1:3, as.Date(c(1L, NA, 3L), origin = "1970-01-01"))) } test.xts_order.by_NA_double <- function() { checkException(xts(1:3, .POSIXct(c(1, 2, NA)))) checkException(xts(1:3, .POSIXct(c(NA, 2, 3)))) checkException(xts(1:3, .POSIXct(c(1, NA, 3)))) } test.xts_order.by_NaN_double <- function() { checkException(xts(1:3, .POSIXct(c(1, 2, NaN)))) checkException(xts(1:3, .POSIXct(c(NaN, 2, 3)))) checkException(xts(1:3, .POSIXct(c(1, NaN, 3)))) } test.xts_order.by_Inf_double <- function() { checkException(xts(1:3, .POSIXct(c(1, 2, Inf)))) checkException(xts(1:3, .POSIXct(c(-Inf, 2, 3)))) } ### }}} # Test that only first tzone element is stored test.xts_only_use_first_tzone_element <- function() { tz <- "America/Chicago" i <- as.POSIXlt("2018-01-01", tz = tz) y <- xts(1, i) checkIdentical(tz, tzone(y)) } test.xts_no_args_has_index_with_tzone_tclass <- function() { x <- xts() checkTrue(!is.null(attr(.index(x), "tclass"))) checkTrue(!is.null(attr(.index(x), "tzone"))) } # don't add index attributes to xts object test.ctors_dont_add_tclass_indexCLASS_to_object <- function() { x <- xts(1, as.Date("2018-05-02")) checkIdentical(NULL, attr(x, "tclass")) checkIdentical(NULL, attr(x, ".indexCLASS")) y <- .xts(1, 1) checkIdentical(NULL, attr(y, "tclass")) checkIdentical(NULL, attr(y, ".indexCLASS")) } test.ctors_dont_add_tzone_indexTZ_to_object <- function() { x <- xts(1, as.Date("2018-05-02")) checkIdentical(NULL, attr(x, "tzone")) checkIdentical(NULL, attr(x, ".indexTZ")) y <- .xts(1, 1) checkIdentical(NULL, attr(y, "tzone")) checkIdentical(NULL, attr(y, ".indexTZ")) } test.ctors_dont_add_indexFORMAT_to_object <- function() { x <- xts(1, as.Date("2018-05-02")) checkIdentical(NULL, attr(x, ".indexFORMAT")) y <- .xts(1, 1) checkIdentical(NULL, attr(y, ".indexFORMAT")) } # warn if deprecated arguments passed to constructor test.xts_ctor_warns_for_indexCLASS_arg <- function() { op <- options(warn = 2) on.exit(options(warn = op$warn)) checkException(x <- xts(1, as.Date("2018-05-02"), .indexCLASS = "Date")) checkException(x <- .xts(1, as.Date("2018-05-02"), .indexCLASS = "Date")) } test.xts_ctor_warns_for_indexTZ_arg <- function() { op <- options(warn = 2) on.exit(options(warn = op$warn)) checkException(x <- xts(1, as.Date("2018-05-02"), .indexTZ = "UTC")) checkException(x <- .xts(1, as.Date("2018-05-02"), .indexTZ = "UTC")) } test.xts_ctor_warns_for_indexFORMAT_arg <- function() { op <- options(warn = 2) on.exit(options(warn = op$warn)) checkException(x <- xts(1, as.Date("2018-05-02"), .indexFORMAT = "%Y")) checkException(x <- .xts(1, as.Date("2018-05-02"), .indexFORMAT = "%Y")) } # .xts() test..xts_dimnames_in_dots <- function() { x <- .xts(1:5, 1:5, dimnames = list(NULL, "x")) y <- xts(1:5, index(x), dimnames = list(NULL, "x")) checkEquals(x, y) } test..xts_ctor_warns_if_index_tclass_not_NULL_or_POSIXct <- function() { DEACTIVATED("Warning causes errors in dependencies") op <- options(warn = 2) on.exit(options(warn = op$warn)) idx <- 1:3 x <- .xts(1:3, idx) # no error, NULL idx <- .POSIXct(idx) x <- .xts(1:3, idx) # no error, POSIXct idx <- structure(1:3, tclass = "Date", tzone = "UTC") checkException(.xts(1:3, idx), msg = "tclass = Date") idx <- structure(idx, tclass = "yearmon", tzone = "UTC") checkException(.xts(1:3, idx), msg = "tclass = yearmon") idx <- structure(idx, tclass = "timeDate", tzone = "UTC") checkException(.xts(1:3, idx), msg = "tclass = timeDate") } checkXtsFormat <- function(xts, format) { checkIdentical(tformat(xts), format) checkIdentical(attr(attr(xts, "index"), "tformat"), format) } ### Check that index format attribute precedence is: ### .indexFORMAT argument > tformat argument > tformat index attribute test..xts_index_format_precedence <- function() { fmt <- "%Y-%m-%d" checkXtsFormat(.xts(1, 1), NULL) checkXtsFormat(.xts(1, 1, tformat=fmt), fmt) checkXtsFormat(.xts(1, 1, .indexFORMAT=fmt), fmt) checkXtsFormat(.xts(1, 1, tformat="%Y", .indexFORMAT=fmt), fmt) ## check constructor arguments override existing index attribute idx <- structure(1, tzone="", tclass="yearmon", tformat="%Y-%b") fmt <- "%Y-%m" checkXtsFormat(.xts(1, idx), "%Y-%b") checkXtsFormat(.xts(1, idx, tformat=fmt), fmt) checkXtsFormat(.xts(1, idx, .indexFORMAT=fmt), fmt) checkXtsFormat(.xts(1, idx, tformat="%b%y", .indexFORMAT=fmt), fmt) } test..xts_user_attributes <- function() { x <- .xts(1, 1, tformat = "%Y", .indexCLASS = "Date", .indexTZ = "UTC", user = "attribute", hello = "world", dimnames = list(NULL, "x")) checkIdentical(NULL, attr(x, "tformat")) checkIdentical(NULL, attr(x, "tclass")) checkIdentical(NULL, attr(x, "tzone")) checkIdentical(NULL, attr(x, ".indexCLASS")) checkIdentical(NULL, attr(x, ".indexTZ")) checkIdentical("attribute", attr(x, "user")) checkIdentical("world", attr(x, "hello")) checkIdentical("x", colnames(x)) } checkXtsClass <- function(xts, class) { checkEquals(tclass(xts), class) checkEquals(attr(attr(xts, "index"), "tclass"), class) } ### Check that index class attribute precedence is: ### .indexCLASS argument > tclass argument > tclass index attribute test..xts_index_class_precedence <- function() { checkXtsClass(.xts(1, 1), c("POSIXct", "POSIXt")) checkXtsClass(.xts(1, 1, tclass="timeDate"), "timeDate") checkXtsClass(.xts(1, 1, .indexCLASS="Date"), "Date") checkXtsClass(.xts(1, 1, tclass="timeDate", .indexCLASS="Date"), "Date") ## also check that tclass is ignored if specified as part of index idx <- structure(1, tzone="",tclass="yearmon") checkXtsClass(.xts(1, idx), c("POSIXct", "POSIXt")) checkXtsClass(.xts(1, idx, tclass="timeDate"), "timeDate") checkXtsClass(.xts(1, idx, .indexCLASS="Date"), "Date") checkXtsClass(.xts(1, idx, tclass="timeDate", .indexCLASS="Date"), "Date") } checkXtsTz <- function(xts, tzone) { checkEquals(tzone(xts), tzone) checkEquals(attr(attr(xts, "index"), "tzone"), tzone) } ### Check that tzone is honoured and .indexTZ ignored ### Check that index timezone attribute precedence is: ### .indexTZ argument > tzone argument > tzone index attribute ### tzone argument > tzone argument > tzone index attribute test..xts_index_tzone_precedence <- function() { sysTZ <- Sys.getenv("TZ") Sys.setenv(TZ = "UTC") on.exit(Sys.setenv(TZ = sysTZ), add = TRUE) checkXtsTz(.xts(1, 1), "UTC") checkXtsTz(.xts(1, 1, tzone="Europe/London"), "Europe/London") ## this case passes in 0.10-2 but looks wrong checkXtsTz(.xts(1, 1, .indexTZ="America/New_York"), "UTC") checkXtsTz(.xts(1, 1, tzone="Europe/London", .indexTZ="America/New_York"), "Europe/London") ## Cases where tzone is specified in the index idx <- structure(1, tzone="Asia/Tokyo",tclass="yearmon") checkXtsTz(.xts(1, idx), "Asia/Tokyo") checkXtsTz(.xts(1, idx, tzone="Europe/London"), "Europe/London") checkXtsTz(.xts(1, idx, .indexTZ="America/New_York"), "Asia/Tokyo") checkXtsTz(.xts(1, idx, tzone="Europe/London", .indexTZ="America/New_York"), "Europe/London") } xts/inst/unitTests/runit.endpoints.R0000644000176200001440000001606413564762102017352 0ustar liggesusers # index crosses the unix epoch test.double_index_cross_epoch <- function() { x <- .xts(1:22, 1.0*(-10:11), tzone="UTC") ep <- endpoints(x, "seconds", 2) checkIdentical(ep, 0:11*2L) } test.integer_index_cross_epoch <- function() { x <- .xts(1:22, -10:11, tzone="UTC") ep <- endpoints(x, "seconds", 2) checkIdentical(ep, 0:11*2L) } #{{{daily data data(sample_matrix) xDailyDblIdx <- as.xts(sample_matrix, dateFormat="Date") xDailyIntIdx <- xDailyDblIdx storage.mode(.index(xDailyIntIdx)) <- "integer" test.days_double_index <- function() { ep <- endpoints(xDailyDblIdx, "days", 7) checkIdentical(ep, c(0L, 1:25*7L-1L, nrow(xDailyDblIdx))) } test.days_integer_index <- function() { ep <- endpoints(xDailyIntIdx, "days", 7) checkIdentical(ep, c(0L, 1:25*7L-1L, nrow(xDailyIntIdx))) } test.weeks_double_index <- function() { ep <- endpoints(xDailyDblIdx, "weeks", 1) checkIdentical(ep, c(0L, 1:25*7L-1L, nrow(xDailyDblIdx))) } test.weeks_integer_index <- function() { ep <- endpoints(xDailyIntIdx, "weeks", 1) checkIdentical(ep, c(0L, 1:25*7L-1L, nrow(xDailyIntIdx))) } test.months_double_index <- function() { ep <- endpoints(xDailyDblIdx, "months", 1) checkIdentical(ep, c(0L, 30L, 58L, 89L, 119L, 150L, 180L)) } test.months_integer_index <- function() { ep <- endpoints(xDailyIntIdx, "months", 1) checkIdentical(ep, c(0L, 30L, 58L, 89L, 119L, 150L, 180L)) } test.quarters_double_index <- function() { ep <- endpoints(xDailyDblIdx, "quarters", 1) checkIdentical(ep, c(0L, 89L, 180L)) } test.quarters_integer_index <- function() { ep <- endpoints(xDailyIntIdx, "quarters", 1) checkIdentical(ep, c(0L, 89L, 180L)) } test.years_double_index <- function() { d <- seq(as.Date("1970-01-01"), by="1 day", length.out=365*5) x <- xts(seq_along(d), d) ep <- endpoints(x, "years", 1) checkIdentical(ep, c(0L, 365L, 730L, 1096L, 1461L, 1825L)) } test.years_integer_index <- function() { d <- seq(as.Date("1970-01-01"), by="1 day", length.out=365*5) x <- xts(seq_along(d), d) storage.mode(.index(x)) <- "integer" ep <- endpoints(x, "years", 1) checkIdentical(ep, c(0L, 365L, 730L, 1096L, 1461L, 1825L)) } #}}} #{{{second data n <- 86400L %/% 30L * 365L * 2L xSecIntIdx <- .xts(1L:n, seq(.POSIXct(0, tz="UTC"), by="30 sec", length.out=n), tzone="UTC") xSecDblIdx <- xSecIntIdx storage.mode(.index(xSecDblIdx)) <- "double" test.seconds_double_index <- function() { ep <- endpoints(xSecDblIdx, "seconds", 3600) checkIdentical(ep, seq(0L, nrow(xSecDblIdx), 120L)) } test.seconds_integer_index <- function() { ep <- endpoints(xSecIntIdx, "seconds", 3600) checkIdentical(ep, seq(0L, nrow(xSecIntIdx), 120L)) } test.seconds_secs <- function() { x <- .xts(1:10, 1:10/6) ep1 <- endpoints(x, "seconds") ep2 <- endpoints(x, "secs") checkIdentical(ep1, ep2) } test.minutes_double_index <- function() { ep <- endpoints(xSecDblIdx, "minutes", 60) checkIdentical(ep, seq(0L, nrow(xSecDblIdx), 120L)) } test.minutes_integer_index <- function() { ep <- endpoints(xSecIntIdx, "minutes", 60) checkIdentical(ep, seq(0L, nrow(xSecIntIdx), 120L)) } test.minutes_mins <- function() { x <- .xts(1:10, 1:10*10) ep1 <- endpoints(x, "minutes") ep2 <- endpoints(x, "mins") checkIdentical(ep1, ep2) } test.hours_double_index <- function() { ep <- endpoints(xSecDblIdx, "hours", 1) checkIdentical(ep, seq(0L, nrow(xSecDblIdx), 120L)) } test.hours_integer_index <- function() { ep <- endpoints(xSecIntIdx, "hours", 1) checkIdentical(ep, seq(0L, nrow(xSecIntIdx), 120L)) } test.days_double_index <- function() { ep <- endpoints(xSecDblIdx, "days", 1) checkIdentical(ep, seq(0L, by=2880L, length.out=length(ep))) } test.days_integer_index <- function() { ep <- endpoints(xSecIntIdx, "days", 1) checkIdentical(ep, seq(0L, by=2880L, length.out=length(ep))) } test.weeks_double_index <- function() { ep <- endpoints(xSecDblIdx, "weeks", 1) ep2 <- c(0L, seq(11520L, nrow(xSecDblIdx)-1L, 20160L), nrow(xSecDblIdx)) checkIdentical(ep, ep2) } test.weeks_integer_index <- function() { ep <- endpoints(xSecIntIdx, "weeks", 1) ep2 <- c(0L, seq(11520L, nrow(xSecIntIdx)-1L, 20160L), nrow(xSecIntIdx)) checkIdentical(ep, ep2) } test.months_double_index <- function() { ep <- endpoints(xSecDblIdx, "months", 1) n <- 86400L * c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) / 30 ep2 <- as.integer(cumsum(c(0L, n, n))) checkIdentical(ep, ep2) } test.months_integer_index <- function() { ep <- endpoints(xSecIntIdx, "months", 1) n <- 86400L * c(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31) / 30 ep2 <- as.integer(cumsum(c(0L, n, n))) checkIdentical(ep, ep2) } test.quarters_double_index <- function() { ep <- endpoints(xSecDblIdx, "quarters", 1) n <- 86400L * c(90, 91, 92, 92) / 30 ep2 <- as.integer(cumsum(c(0L, n, n))) checkIdentical(ep, ep2) } test.quarters_integer_index <- function() { ep <- endpoints(xSecIntIdx, "quarters", 1) n <- 86400L * c(90, 91, 92, 92) / 30 ep2 <- as.integer(cumsum(c(0L, n, n))) checkIdentical(ep, ep2) } test.years_double_index <- function() { ep <- endpoints(xSecDblIdx, "years", 1) checkIdentical(ep, c(0L, 1051200L, 2102400L)) } test.years_integer_index <- function() { ep <- endpoints(xSecIntIdx, "years", 1) checkIdentical(ep, c(0L, 1051200L, 2102400L)) } #}}} # sparse endpoints could be a problem with POSIXlt elements (#169) # TODO: sparse intraday endpoints test.sparse_years <- function() { x <- xts(2:6, as.Date(sprintf("199%d-06-01", 2:6))) ep <- endpoints(x, "years") checkIdentical(ep, 0:5) } test.sparse_quarters <- function() { x <- xts(2:6, as.Date(sprintf("199%d-06-01", 2:6))) ep <- endpoints(x, "quarters") checkIdentical(ep, 0:5) } test.sparse_months <- function() { x <- xts(2:6, as.Date(sprintf("199%d-06-01", 2:6))) ep <- endpoints(x, "months") checkIdentical(ep, 0:5) } test.sparse_weeks <- function() { x <- xts(2:6, as.Date(sprintf("199%d-06-01", 2:6))) ep <- endpoints(x, "weeks") checkIdentical(ep, 0:5) } test.sparse_days <- function() { x <- xts(2:6, as.Date(sprintf("199%d-06-01", 2:6))) ep <- endpoints(x, "days") checkIdentical(ep, 0:5) } # sub-second resolution on Windows test.sub_second_resolution <- function() { x <- .xts(1:6, .POSIXct(0:5 / 10 + 0.01)) ep <- endpoints(x, "ms", 250) checkIdentical(ep, c(0L, 3L, 5L, 6L)) } # precision issues test.sub_second_resolution_exact <- function() { x <- .xts(1:6, .POSIXct(0:5 / 10)) ep <- endpoints(x, "ms", 250) checkIdentical(ep, c(0L, 3L, 5L, 6L)) } test.sub_second_resolution_representation <- function() { x <- .xts(1:10, .POSIXct(1.5e9 + 0:9 / 10)) ep <- endpoints(x, "ms", 200) checkIdentical(ep, seq(0L, 10L, 2L)) } # on = "quarters", k > 1 test.multiple_quarters <- function() { x <- xts(1:48, as.yearmon("2015-01-01") + 0:47 / 12) checkIdentical(endpoints(x, "quarters", 1), seq(0L, 48L, 3L)) checkIdentical(endpoints(x, "quarters", 2), seq(0L, 48L, 6L)) checkIdentical(endpoints(x, "quarters", 3), seq(0L, 48L, 9L)) checkIdentical(endpoints(x, "quarters", 4), seq(0L, 48L,12L)) checkIdentical(endpoints(x, "quarters", 5), seq(0L, 48L,15L)) checkIdentical(endpoints(x, "quarters", 6), seq(0L, 48L,18L)) } xts/inst/unitTests/runit.first-last.R0000644000176200001440000001577413564762102017446 0ustar liggesusersdates <- c("2017-01-01", "2017-01-02", "2017-01-03") d1 <- data.frame(x = seq_along(dates), row.names = dates) d2 <- data.frame(d1, y = rev(seq_along(dates))) # basic functionality on data.frame test.first_xtsible_data.frame_pos_n <- function() { checkIdentical(first(d1, 1), head(d1, 1)) checkIdentical(first(d2, 1), head(d2, 1)) checkIdentical(first(d1, "1 day"), head(d1, 1)) checkIdentical(first(d2, "1 day"), head(d2, 1)) } test.first_xtsible_data.frame_neg_n <- function() { checkIdentical(first(d1, -1), tail(d1, -1)) checkIdentical(first(d2, -1), tail(d2, -1)) checkIdentical(first(d1, "-1 day"), tail(d1, -1)) checkIdentical(first(d2, "-1 day"), tail(d2, -1)) } test.last_xtsible_data.frame_pos_n <- function() { checkIdentical(last(d1, 1), tail(d1, 1)) checkIdentical(last(d2, 1), tail(d2, 1)) checkIdentical(last(d1, "1 day"), tail(d1, 1)) checkIdentical(last(d2, "1 day"), tail(d2, 1)) } test.last_xtsible_data.frame_neg_n <- function() { checkIdentical(last(d1, -1), head(d1, -1)) checkIdentical(last(d2, -1), head(d2, -1)) checkIdentical(last(d1, "-1 day"), head(d1, -1)) checkIdentical(last(d2, "-1 day"), head(d2, -1)) } test.first_nonxtsible_data.frame_pos_n <- function() { rownames(d1) <- rownames(d2) <- NULL checkIdentical(first(d1, 1), head(d1, 1)) checkIdentical(first(d2, 1), head(d2, 1)) } test.first_nonxtsible_data.frame_neg_n <- function() { rownames(d1) <- rownames(d2) <- NULL checkIdentical(first(d1, -1), tail(d1, -1)) checkIdentical(first(d2, -1), tail(d2, -1)) } test.last_nonxtsible_data.frame_pos_n <- function() { rownames(d1) <- rownames(d2) <- NULL checkIdentical(last(d1, 1), tail(d1, 1)) checkIdentical(last(d2, 1), tail(d2, 1)) } test.last_nonxtsible_data.frame_neg_n <- function() { rownames(d1) <- rownames(d2) <- NULL checkIdentical(last(d1, -1), head(d1, -1)) checkIdentical(last(d2, -1), head(d2, -1)) } # basic functionality on matrix m1 <- as.matrix(d1) m2 <- as.matrix(d2) test.first_xtsible_matrix_pos_n <- function() { checkIdentical(first(m1, 1), head(m1, 1)) checkIdentical(first(m2, 1), head(m2, 1)) checkIdentical(first(m1, "1 day"), head(m1, 1)) checkIdentical(first(m2, "1 day"), head(m2, 1)) } test.first_xtsible_matrix_neg_n <- function() { checkIdentical(first(m1, -1), tail(m1, -1, addrownums = FALSE)) checkIdentical(first(m2, -1), tail(m2, -1, addrownums = FALSE)) checkIdentical(first(m1, "-1 day"), tail(m1, -1, addrownums = FALSE)) checkIdentical(first(m2, "-1 day"), tail(m2, -1, addrownums = FALSE)) } test.last_xtsible_matrix_pos_n <- function() { checkIdentical(last(m1, 1), tail(m1, 1, addrownums = FALSE)) checkIdentical(last(m2, 1), tail(m2, 1, addrownums = FALSE)) checkIdentical(last(m1, "1 day"), tail(m1, 1, addrownums = FALSE)) checkIdentical(last(m2, "1 day"), tail(m2, 1, addrownums = FALSE)) } test.last_xtsible_matrix_neg_n <- function() { checkIdentical(last(m1, -1), head(m1, -1)) checkIdentical(last(m2, -1), head(m2, -1)) } test.first_nonxtsible_matrix_pos_n <- function() { rownames(m1) <- rownames(m2) <- NULL checkIdentical(first(m1, 1), head(m1, 1)) checkIdentical(first(m2, 1), head(m2, 1)) } test.first_nonxtsible_matrix_neg_n <- function() { rownames(m1) <- rownames(m2) <- NULL checkIdentical(first(m1, -1), tail(m1, -1, addrownums = FALSE)) checkIdentical(first(m2, -1), tail(m2, -1, addrownums = FALSE)) } test.last_nonxtsible_matrix_pos_n <- function() { rownames(m1) <- rownames(m2) <- NULL checkIdentical(last(m1, 1), tail(m1, 1, addrownums = FALSE)) checkIdentical(last(m2, 1), tail(m2, 1, addrownums = FALSE)) } test.last_nonxtsible_matrix_neg_n <- function() { rownames(m1) <- rownames(m2) <- NULL checkIdentical(last(m1, -1), head(m1, -1)) checkIdentical(last(m2, -1), head(m2, -1)) } # basic functionality on vector test.first_xtsible_vector <- function() { v1 <- setNames(d1$x, rownames(d1)) checkIdentical(first(v1, 1), head(v1, 1)) checkIdentical(first(v1,-1), tail(v1,-1)) checkIdentical(first(v1, "1 day"), head(v1, 1)) checkIdentical(first(v1,"-1 day"), tail(v1,-1)) checkIdentical(first(v1, "2 days"), head(v1, 2)) checkIdentical(first(v1,"-2 days"), tail(v1,-2)) d <- .Date(3) + 1:21 checkIdentical(first(d, "1 week"), head(d, 7)) checkIdentical(first(d,"-1 week"), tail(d,-7)) checkIdentical(first(d, "2 weeks"), head(d, 14)) checkIdentical(first(d,"-2 weeks"), tail(d,-14)) } test.last_xtsible_vector <- function() { v1 <- setNames(d1$x, rownames(d1)) checkIdentical(last(v1, 1), tail(v1, 1)) checkIdentical(last(v1,-1), head(v1,-1)) checkIdentical(last(v1, "1 day"), tail(v1, 1)) checkIdentical(last(v1,"-1 day"), head(v1,-1)) d <- .Date(3) + 1:21 checkIdentical(last(d, "1 week"), tail(d, 7)) checkIdentical(last(d,"-1 week"), head(d,-7)) checkIdentical(last(d, "2 weeks"), tail(d, 14)) checkIdentical(last(d,"-2 weeks"), head(d,-14)) } test.first_nonxtsible_vector <- function() { v1 <- d1$x checkIdentical(first(v1, 1), head(v1, 1)) checkIdentical(first(v1,-1), tail(v1,-1)) } test.last_nonxtsible_vector <- function() { v1 <- d1$x checkIdentical(last(v1, 1), tail(v1, 1)) checkIdentical(last(v1,-1), head(v1,-1)) } # zero-length vectors test.zero_length_vector <- function() { types <- c("logical", "integer", "numeric", "complex", "character", "raw") for (type in types) { v <- vector(type, 0) checkIdentical(first(v, 1), v, paste("zero-length", type)) checkIdentical(last(v, 1), v, paste("zero-length", type)) # negative 'n' checkIdentical(first(v, -1), v, paste("zero-length", type)) checkIdentical(last(v, -1), v, paste("zero-length", type)) } } # zero-row matrix test.zero_row_matrix <- function() { types <- c("logical", "integer", "numeric", "complex", "character", "raw") for (type in types) { m <- matrix(vector(type, 0), 0) checkIdentical(first(m, 1), m, paste("zero-row", type)) checkIdentical(last(m, 1), m, paste("zero-row", type)) # negative 'n' checkIdentical(first(m, -1), m, paste("zero-row", type)) checkIdentical(last(m, -1), m, paste("zero-row", type)) } } # tests for zoo z1 <- zoo(seq_along(dates), as.Date(dates)) z2 <- merge(x = z1, y = rev(seq_along(dates))) test.first_zoo_pos_n <- function() { checkIdentical(first(z1, 1), head(z1, 1)) checkIdentical(first(z2, 1), head(z2, 1)) checkIdentical(first(z1, "1 day"), head(z1, 1)) checkIdentical(first(z2, "1 day"), head(z2, 1)) } test.first_zoo_neg_n <- function() { checkIdentical(first(z1, -1), tail(z1, -1)) checkIdentical(first(z2, -1), tail(z2, -1)) checkIdentical(first(z1, "-1 day"), tail(z1, -1)) checkIdentical(first(z2, "-1 day"), tail(z2, -1)) } test.last_zoo_pos_n <- function() { checkIdentical(last(z1, 1), tail(z1, 1)) checkIdentical(last(z2, 1), tail(z2, 1)) checkIdentical(last(z1, "1 day"), tail(z1, 1)) checkIdentical(last(z2, "1 day"), tail(z2, 1)) } test.last_zoo_neg_n <- function() { checkIdentical(last(z1, -1), head(z1, -1)) checkIdentical(last(z2, -1), head(z2, -1)) checkIdentical(last(z1, "-1 day"), head(z1, -1)) checkIdentical(last(z2, "-1 day"), head(z2, -1)) } xts/inst/unitTests/runit.data.frame.R0000644000176200001440000000415213564762102017344 0ustar liggesusersdata(sample_matrix) sample.data.frame <- data.frame(sample_matrix) sample.xts <- as.xts(sample.data.frame) test.convert_data.frame_to_xts <- function() { checkIdentical(sample.xts,as.xts(sample.data.frame)) } test.convert_data.frame_to_xts_j1 <- function() { checkIdentical(sample.xts[,1],as.xts(sample.data.frame)[,1]) } test.convert_data.frame_to_xts_i1 <- function() { checkIdentical(sample.xts[1,],as.xts(sample.data.frame)[1,]) } test.convert_data.frame_to_xts_i1j1 <- function() { checkIdentical(sample.xts[1,1],as.xts(sample.data.frame)[1,1]) } test.data.frame_reclass <- function() { checkIdentical(sample.data.frame,reclass(try.xts(sample.data.frame))) } test.data.frame_reclass_subset_reclass_j1 <- function() { checkIdentical(sample.data.frame[,1],reclass(try.xts(sample.data.frame))[,1]) } # subsetting to 1 col converts to simple numeric - can't successfully handle test.data.frame_reclass_subset_as.xts_j1 <- function() { checkIdentical(sample.data.frame[,1,drop=FALSE],reclass(try.xts(sample.data.frame)[,1])) } test.data.frame_reclass_subset_data.frame_j1 <- function() { # subsetting results in a vector, so can't be converted to xts checkException(try.xts(sample.data.frame[,1])) } # check for as.xts.data.frame when order.by is specified test.convert_data.frame_to_xts_order.by_POSIXlt <- function() { orderby = as.POSIXlt(rownames(sample.data.frame)) x <- as.xts(sample.data.frame, order.by = orderby) # tz = "" by default for as.POSIXlt.POSIXct y <- xts(coredata(sample.xts), as.POSIXlt(index(sample.xts))) checkIdentical(y, x) } test.convert_data.frame_to_xts_order.by_POSIXct <- function() { orderby = as.POSIXct(rownames(sample.data.frame)) x <- as.xts(sample.data.frame, order.by = orderby) checkIdentical(sample.xts, x) } test.convert_data.frame_to_xts_order.by_Date <- function() { # tz = "UTC" by default for as.Date.POSIXct (y), but # tz = "" by default for as.Date.character (orderby) orderby = as.Date(rownames(sample.data.frame)) x <- as.xts(sample.data.frame, order.by = orderby) y <- xts(coredata(sample.xts), as.Date(index(sample.xts), tz = "")) checkIdentical(y, x) } xts/inst/unitTests/runit.timeBasedSeq.R0000644000176200001440000000561213564762102017712 0ustar liggesusers# timeBasedSeq test # 1999 to 2008 by year, Date test.tbs_1999_to_2008_by_year_Date <- function() { tbs <- timeBasedSeq('1999/2008') bench <- seq(as.Date("1999-01-01"),as.Date("2008-01-01"),by='year') checkEqualsNumeric(tbs, bench) } # 1999 to 2008 by year, retclass='Date' test.tbs_1999_to_2008_by_year_retclassDate <- function() { tbs <- timeBasedSeq('1999/2008', retclass='Date') bench <- seq(as.Date("1999-01-01"),as.Date("2008-01-01"),by='year') checkEqualsNumeric(tbs, bench) } # 1999 to 2008 by year, retclass="POSIXct" test.tbs_1999_to_2008_by_year <- function() { tbs <- timeBasedSeq('1999/2008',retclass='POSIXct') bench <- seq(as.POSIXct("1999-01-01"),as.POSIXct("2008-01-01"),by='year') checkEqualsNumeric(tbs, bench) } # MONTHLY sequences # defaults to yearmon from the zoo package # NB: these differ by ~4.16e-5 on Solaris and rhub's windows-x86_64-devel test.tbs_199901_to_200801_by_month <- function() { tbs <- timeBasedSeq('199901/200801') bench <- as.yearmon(seq(as.Date("1999-01-01"),as.Date("2008-01-01"),by='month')) checkEqualsNumeric(tbs, bench, tolerance = 1e-4) } test.tbs_199901_to_2008_by_month <- function() { tbs <- timeBasedSeq('199901/2008') bench <- as.yearmon(seq(as.Date("1999-01-01"),as.Date("2008-12-01"),by='month')) checkEqualsNumeric(tbs, bench, tolerance = 1e-4) } test.tbs_1999_to_200801_by_month <- function() { tbs <- timeBasedSeq('1999/200801') bench <- as.yearmon(seq(as.Date("1999-01-01"),as.Date("2008-01-01"),by='month')) checkEqualsNumeric(tbs, bench, tolerance = 1e-4) } # retclass=Date test.tbs_199901_to_200801_by_month_Date <- function() { tbs <- timeBasedSeq('199901/200801', retclass='Date') bench <- seq(as.Date("1999-01-01"),as.Date("2008-01-01"),by='month') checkEqualsNumeric(tbs, bench) } test.tbs_199901_to_2008_by_month_Date <- function() { tbs <- timeBasedSeq('199901/2008', retclass='Date') bench <- seq(as.Date("1999-01-01"),as.Date("2008-12-01"),by='month') checkEqualsNumeric(tbs, bench) } test.tbs_1999_to_200801_by_month_Date <- function() { tbs <- timeBasedSeq('1999/200801', retclass='Date') bench <- as.Date(seq(as.Date("1999-01-01"),as.Date("2008-01-01"),by='month')) checkEqualsNumeric(tbs, bench) } # retclass=POSIXct test.tbs_199901_to_200801_by_month_POSIXct <- function() { tbs <- timeBasedSeq('199901/200801', retclass='POSIXct') bench <- seq(as.POSIXct("1999-01-01"),as.POSIXct("2008-01-01"),by='month') checkEqualsNumeric(tbs, bench) } test.tbs_199901_to_2008_by_month_POSIXct <- function() { tbs <- timeBasedSeq('199901/2008', retclass='POSIXct') bench <- as.POSIXct(seq(as.POSIXct("1999-01-01"),as.POSIXct("2008-12-01"),by='month'),tzone='GMT') checkEqualsNumeric(tbs, bench) } test.tbs_1999_to_200801_by_month_POSIXct <- function() { tbs <- timeBasedSeq('1999/200801', retclass='POSIXct') bench <- seq(as.POSIXct("1999-01-01"),as.POSIXct("2008-01-01"),by='month') checkEqualsNumeric(tbs, bench) } xts/inst/unitTests/runit.na.locf.R0000644000176200001440000001201713564762102016661 0ustar liggesusersXDAT <- .xts(c(1, NA, 3, 4, 5, 6), c(0, 4, 10, 19, 24, 29)) XIDX <- .xts(rep(0, 5), c(5, 10, 20, 25, 28)) MODES <- c("double", "integer", "character", "logical") # na.locf.xts() on a univariate xts object test.nalocf <- function() { for (m in MODES) { xdat <- XDAT storage.mode(xdat) <- m zdat <- as.zoo(xdat) x <- na.locf(xdat) z <- na.locf(zdat) #checkIdentical(x, as.xts(z)) # FALSE (attribute order differs) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_leading_NA <- function() { for (m in MODES) { xdat <- XDAT storage.mode(xdat) <- m zdat <- as.zoo(xdat) xdat[1] <- NA zdat[1] <- NA x <- na.locf(xdat, na.rm = TRUE) z <- na.locf(zdat, na.rm = TRUE) checkEquals(x, as.xts(z), check.attributes = TRUE) x <- na.locf(xdat, na.rm = FALSE) z <- na.locf(zdat, na.rm = FALSE) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_fromLast <- function() { for (m in MODES) { xdat <- XDAT storage.mode(xdat) <- m zdat <- as.zoo(xdat) x <- na.locf(xdat, fromLast = TRUE) z <- na.locf(zdat, fromLast = TRUE) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_x <- function() { for (m in MODES) { xdat <- XDAT xidx <- XIDX storage.mode(xdat) <- storage.mode(xidx) <- m zdat <- as.zoo(xdat) zidx <- as.zoo(xidx) xidx <- rbind(xidx, .xts(0, 30)) zidx <- as.zoo(xidx) x <- na.locf(xdat, x = index(xidx)) z <- na.locf(zdat, x = index(zidx)) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_xout <- function() { for (m in MODES) { xdat <- XDAT xidx <- XIDX storage.mode(xdat) <- storage.mode(xidx) <- m zdat <- as.zoo(xdat) zidx <- as.zoo(xidx) x <- na.locf(xdat, xout = index(xidx)) z <- na.locf(zdat, xout = index(zidx)) checkEquals(x, as.xts(z), check.attributes = TRUE) } } # na.locf.xts() on a multivariate xts object XDAT2 <- merge(one = XDAT, two = XDAT) test.nalocf_by_column <- function() { for (m in MODES) { xdat <- XDAT2 storage.mode(xdat) <- m zdat <- as.zoo(xdat) x <- na.locf(xdat) z <- na.locf(zdat) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_by_column_leading_NA <- function() { for (m in MODES) { xdat <- XDAT2 storage.mode(xdat) <- m zdat <- as.zoo(xdat) xdat[1] <- NA zdat[1] <- NA if (FALSE) { # bug w/zoo causes this to fail # zoo:::na.locf.default() does not remove the first row x <- na.locf(xdat, na.rm = TRUE) z <- na.locf(zdat, na.rm = TRUE) checkEquals(x, as.xts(z), check.attributes = TRUE) } x <- na.locf(xdat, na.rm = FALSE) z <- na.locf(zdat, na.rm = FALSE) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_by_column_fromLast <- function() { for (m in MODES) { xdat <- XDAT2 storage.mode(xdat) <- m zdat <- as.zoo(xdat) x <- na.locf(xdat, fromLast = TRUE) z <- na.locf(zdat, fromLast = TRUE) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_by_column_x <- function() { for (m in MODES) { xdat <- XDAT2 xidx <- XIDX storage.mode(xdat) <- storage.mode(xidx) <- m zdat <- as.zoo(xdat) zidx <- as.zoo(xidx) xidx <- rbind(xidx, .xts(0, 30)) zidx <- as.zoo(xidx) x <- na.locf(xdat, x = index(xidx)) z <- na.locf(zdat, x = index(zidx)) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_by_column_xout <- function() { for (m in MODES) { xdat <- XDAT2 xidx <- XIDX storage.mode(xdat) <- storage.mode(xidx) <- m zdat <- as.zoo(xdat) zidx <- as.zoo(xidx) x <- na.locf(xdat, xout = index(xidx)) z <- na.locf(zdat, xout = index(zidx)) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_by_column_1NA <- function() { narow <- 1L for (m in MODES) { xdrow <- XDAT2[narow,] xdat <- XDAT2 * NA xdat[narow,] <- xdrow storage.mode(xdat) <- m zdat <- as.zoo(xdat) x <- na.locf(xdat) z <- na.locf(zdat) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_by_column_1NA_fromLast <- function() { narow <- nrow(XDAT2) for (m in MODES) { xdrow <- XDAT2[narow,] xdat <- XDAT2 * NA xdat[narow,] <- xdrow storage.mode(xdat) <- m zdat <- as.zoo(xdat) x <- na.locf(xdat, fromLast = TRUE) z <- na.locf(zdat, fromLast = TRUE) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_first_column_all_NA <- function() { nacol <- 1L for (m in MODES) { xdat <- XDAT2 xdat[,nacol] <- xdat[,nacol] * NA storage.mode(xdat) <- m zdat <- as.zoo(xdat) x <- na.locf(xdat) z <- na.locf(zdat) checkEquals(x, as.xts(z), check.attributes = TRUE) } } test.nalocf_last_column_all_NA <- function() { nacol <- NCOL(XDAT2) for (m in MODES) { xdat <- XDAT2 xdat[,nacol] <- xdat[,nacol] * NA storage.mode(xdat) <- m zdat <- as.zoo(xdat) x <- na.locf(xdat) z <- na.locf(zdat) checkEquals(x, as.xts(z), check.attributes = TRUE) } } xts/inst/unitTests/runit.diff.R0000644000176200001440000000351013564762102016247 0ustar liggesusers # POSIXct index test.diff_integer_POSIXt <- function() { x <- .xts(1:5, 1:5 + 0.0) dx <- xts(rbind(NA_integer_, diff(coredata(x))), index(x)) checkIdentical(diff(x), dx) } test.diff_numeric_POSIXt <- function() { x <- .xts(1:5 + 1.0, 1:5 + 0.0) dx <- xts(rbind(NA_real_, diff(coredata(x))), index(x)) checkIdentical(diff(x), dx) } test.diff_logical_POSIXt <- function() { x <- .xts(1:5 > 2, 1:5 + 0.0) dx <- xts(rbind(NA, diff(coredata(x))), index(x)) checkIdentical(diff(x), dx) } # Date index test.diff_integer_Date <- function() { x <- xts(1:5, as.Date("2016-01-01") - 5:1) dx <- xts(rbind(NA_integer_, diff(coredata(x))), index(x)) checkIdentical(diff(x), dx) } test.diff_numeric_Date <- function() { x <- xts(1:5 + 1.0, as.Date("2016-01-01") - 5:1) dx <- xts(rbind(NA_real_, diff(coredata(x))), index(x)) checkIdentical(diff(x), dx) } test.diff_logical_Date <- function() { x <- xts(1:5 > 2, as.Date("2016-01-01") - 5:1) dx <- xts(rbind(NA, diff(coredata(x))), index(x)) checkIdentical(diff(x), dx) } # Type-check failure errors test.diff_differences_NA <- function() { x <- .xts(1:5, 1:5) checkException(diff(x, 1L, "a"), "'differences' must be integer") } test.diff_lag_NA <- function() { x <- .xts(1:5, 1:5) checkException(diff(x, "a", 1L), "'lag' must be integer") } test.diff_differences_LT1 <- function() { x <- .xts(1:5, 1:5) checkException(diff(x, 1L, -1L), "'diff.xts' defined only for positive lag and differences arguments") } test.diff_lag_LT1 <- function() { x <- .xts(1:5, 1:5) checkException(diff(x, -1L, 1L), "'diff.xts' defined only for positive lag and differences arguments") } test.diff_logical_preserves_colnames <- function() { cnames <- c("a", "b") x <- .xts(matrix(rnorm(10) > 0, 5), 1:5, dimnames = list(NULL, cnames)) y <- diff(x) checkIdentical(colnames(y), cnames) } xts/inst/unitTests/runit.periodicity.R0000644000176200001440000000156713564762102017675 0ustar liggesusersP <- structure( list(difftime = structure(0, units = "secs", class = "difftime"), frequency = 0, start = structure(.POSIXct(1, "UTC"), tclass = c("POSIXct", "POSIXt")), end = structure(.POSIXct(1, "UTC"), tclass = c("POSIXct", "POSIXt")), units = "secs", scale = "seconds", label = "second"), class = "periodicity") test.periodicity_on_one_observation_warns <- function() { x <- xts(1, .POSIXct(1, "UTC")) p <- periodicity(x) checkIdentical(p, P) opt <- options(warn = 2) on.exit(options(warn = opt$warn)) checkException(p <- periodicity(x)) } test.periodicity_on_zero_observations_warns <- function() { x <- xts(, .POSIXct(numeric(0), "UTC")) p <- periodicity(x) P$start <- NA P$end <- NA checkIdentical(p, P) opt <- options(warn = 2) on.exit(options(warn = opt$warn)) checkException(p <- periodicity(x)) } xts/inst/unitTests/runit.split.R0000644000176200001440000000027713564762102016501 0ustar liggesusers# 'f' is character, but length(f) > 1 test.split_character_f_not_endpoints <- function() { x <- .xts(1:5, 1:5) f <- letters[1:nrow(x)] checkIdentical(split(x,f), split(as.zoo(x),f)) } xts/inst/unitTests/runit.tformat.R0000644000176200001440000000353713564762102017024 0ustar liggesusers# These tests check the 'tformat' attribute is attached to the expected # component of the xts object. The xts constructors should no longer add the # '.indexFORMAT' attribute to the xts object itself. Only the index should # have a 'tformat' attribute. Construct xts objects using structure() to # test behavior when functions encounter xts objects created before 0.10-3. x <- structure(1:5, .Dim = c(5L, 1L), index = structure(1:5, tzone = "", tclass = c("POSIXct", "POSIXt"), tformat = "%Y-%m-%d"), .indexCLASS = c("POSIXct", "POSIXt"), tclass = c("POSIXct", "POSIXt"), .indexTZ = "UTC", tzone = "UTC", .indexFORMAT = "%Y-%m-%d %H:%M:%S", class = c("xts", "zoo")) test.get_tformat <- function() { checkIdentical(tformat(x), "%Y-%m-%d") } test.get_indexFORMAT_warns <- function() { op <- options(warn = 2) on.exit(options(warn = op$warn)) checkException(indexFormat(x)) } test.set_indexFORMAT_warns <- function() { op <- options(warn = 2) on.exit(options(warn = op$warn)) checkException(indexFormat(x) <- "GMT") } test.set_tformat_drops_xts_indexFORMAT <- function() { y <- x tformat(y) <- "%Y-%m-%d %H:%M" checkIdentical(NULL, attr(y, ".indexFORMAT")) } test.set_tformat_changes_index_tformat <- function() { y <- x fmt <- "%Y-%m-%d %H:%M" tformat(y) <- fmt checkIdentical(fmt, attr(attr(y, "index"), "tformat")) } test.get_coredata_drops_xts_indexFORMAT <- function() { y <- coredata(x) checkIdentical(NULL, attr(y, ".indexFORMAT")) } test.get_xtsAttributes_excludes_indexFORMAT <- function() { y <- xtsAttributes(x) checkIdentical(NULL, y$.indexFORMAT) } test.set_xtsAttributes_removes_indexFORMAT <- function() { y <- x xtsAttributes(y) <- xtsAttributes(x) checkIdentical(NULL, attr(y, ".indexFORMAT")) } xts/inst/unitTests/runit.Ops.R0000644000176200001440000003356313564762102016113 0ustar liggesusersall.modes <- c("double", "integer", "logical", "character") ops.math <- c("+", "-", "*", "/", "^", "%%", "%/%") ops.relation <- c(">", ">=", "==", "!=", "<=", "<") ops.logic <- c("&", "|", ops.relation) all.ops <- c(ops.math, ops.logic) ops_numeric_tester <- function(e1, e2, mode, op) { storage.mode(e1) <- mode storage.mode(e2) <- mode eval(call(op, e1, e2)) } ### {{{ 2-column objects test.ops_xts2d_matrix2d_dimnames <- function() { X1 <- .xts(cbind(1:3, 4:6), 1:3, dimnames = list(NULL, c("x", "y"))) M1 <- as.matrix(X1) * 5 M2 <- M1 colnames(M2) <- rev(colnames(M2)) for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, M1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), M1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments should only change column names e <- ops_numeric_tester(M2, X1, m, o) E <- X1 colnames(E) <- colnames(M2) E[] <- ops_numeric_tester(M2, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts2d_matrix2d_only_colnames <- function() { X1 <- .xts(cbind(1:3, 4:6), 1:3, dimnames = list(NULL, c("x", "y"))) M1 <- coredata(X1) * 5 M2 <- M1 colnames(M2) <- rev(colnames(M2)) for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, M1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), M1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments should only change column names e <- ops_numeric_tester(M2, X1, m, o) E <- X1 colnames(E) <- colnames(M2) E[] <- ops_numeric_tester(M2, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts2d_matrix2d_only_rownames <- function() { X1 <- .xts(cbind(1:3, 4:6), 1:3) M1 <- coredata(X1) * 5 rownames(M1) <- format(.POSIXct(1:3)) M2 <- M1 colnames(M2) <- rev(colnames(M2)) for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, M1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), M1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments should only change column names e <- ops_numeric_tester(M2, X1, m, o) E <- X1 colnames(E) <- colnames(M2) E[] <- ops_numeric_tester(M2, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts2d_matrix2d_no_dimnames <- function() { X1 <- .xts(cbind(1:3, 1:3), 1:3) M1 <- coredata(X1) * 5 for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, M1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), M1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments shouldn't matter e <- ops_numeric_tester(M1, X1, m, o) E <- X1 E[] <- ops_numeric_tester(M1, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } ### }}} 2-column objects ### {{{ 1-column objects test.ops_xts1d_matrix1d_dimnames <- function() { X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x")) M1 <- as.matrix(X1) * 5 M2 <- M1 colnames(M2) <- "y" for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, M1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), M1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments should only change column names e <- ops_numeric_tester(M2, X1, m, o) E <- X1 E[] <- ops_numeric_tester(M2, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" colnames(E) <- "y" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts1d_matrix1d_only_colnames <- function() { X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x")) M1 <- coredata(X1) * 5 M2 <- M1 colnames(M2) <- "y" for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, M1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), M1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments should only change column names e <- ops_numeric_tester(M2, X1, m, o) E <- X1 E[] <- ops_numeric_tester(M2, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" colnames(E) <- "y" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts1d_matrix1d_only_rownames <- function() { X1 <- .xts(1:3, 1:3) M1 <- coredata(X1) * 5 rownames(M1) <- format(.POSIXct(1:3)) for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, M1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), M1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments shouldn't matter e <- ops_numeric_tester(M1, X1, m, o) E <- X1 E[] <- ops_numeric_tester(M1, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts1d_matrix1d_no_dimnames <- function() { X1 <- .xts(1:3, 1:3) M1 <- coredata(X1) * 5 for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, M1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), M1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments shouldn't matter e <- ops_numeric_tester(M1, X1, m, o) E <- X1 E[] <- ops_numeric_tester(M1, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts1d_xts1d <- function() { X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x")) for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, X1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(X1), coredata(X1), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts1d_xts1d_different_index <- function() { X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x")) X2 <- .xts(2:4, 2:4, dimnames = list(NULL, "y")) for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, X2, m, o) E <- X1[2:3,] E[] <- ops_numeric_tester(coredata(E), coredata(X2[1:2,]), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments should only change column names e <- ops_numeric_tester(X2, X1, m, o) E <- X2[1:2,] E[] <- ops_numeric_tester(coredata(X1[2:3,]), coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } ### }}} 1-column objects ### {{{ xts with dim, vector test.ops_xts2d_vector_no_names <- function() { X1 <- .xts(cbind(1:3, 4:6), 1:3, dimnames = list(NULL, c("x", "y"))) V1 <- as.vector(coredata(X1[,1L])) * 5 for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, V1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), V1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments shouldn't matter e <- ops_numeric_tester(V1, X1, m, o) E <- X1 E[] <- ops_numeric_tester(V1, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts2d_vector_names <- function() { X1 <- .xts(cbind(1:3, 4:6), 1:3, dimnames = list(NULL, c("x", "y"))) V1 <- setNames(as.vector(X1[,1L]), index(X1)) * 5 for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, V1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), V1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments shouldn't matter e <- ops_numeric_tester(V1, X1, m, o) E <- X1 E[] <- ops_numeric_tester(V1, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts1d_vector_no_names <- function() { X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x")) V1 <- as.vector(coredata(X1[,1L])) * 5 for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, V1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), V1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments shouldn't matter e <- ops_numeric_tester(V1, X1, m, o) E <- X1 E[] <- ops_numeric_tester(V1, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts1d_vector_names <- function() { X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x")) V1 <- setNames(as.vector(X1[,1L]), index(X1)) * 5 for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(X1, V1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(E), V1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments shouldn't matter e <- ops_numeric_tester(V1, X1, m, o) E <- X1 E[] <- ops_numeric_tester(V1, coredata(E), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } ### }}} xts with dim, vector ### {{{ xts no dims, matrix/vector test.ops_xts_no_dim_matrix1d <- function() { X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x")) Xv <- drop(X1) M1 <- coredata(X1) * 5 for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(Xv, M1, m, o) E <- X1 E[] <- ops_numeric_tester(coredata(Xv), M1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments shouldn't matter e <- ops_numeric_tester(M1, Xv, m, o) E <- X1 E[] <- ops_numeric_tester(M1, coredata(Xv), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts_no_dim_matrix2d <- function() { X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x")) Xv <- drop(X1) X2 <- merge(x = Xv * 2, y = Xv * 5) M2 <- coredata(X2) for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(Xv, M2, m, o) E <- X2 E[] <- ops_numeric_tester(coredata(Xv), M2, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" # results no identical because attributes change order checkEquals(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments shouldn't matter e <- ops_numeric_tester(M2, Xv, m, o) E <- X2 E[] <- ops_numeric_tester(M2, coredata(Xv), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" # results no identical because attributes change order checkEquals(e, E, sprintf("op: %s, type: %s", o, m)) } } } test.ops_xts_no_dim_vector <- function() { X1 <- .xts(1:3, 1:3, dimnames = list(NULL, "x")) Xv <- drop(X1) V1 <- 4:6 for (o in all.ops) { for (m in all.modes) { if ("character" == m && !(o %in% ops.relation)) next e <- ops_numeric_tester(Xv, V1, m, o) E <- Xv E[] <- ops_numeric_tester(coredata(Xv), V1, m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) # order of arguments shouldn't matter e <- ops_numeric_tester(V1, Xv, m, o) E <- Xv E[] <- ops_numeric_tester(V1, coredata(Xv), m, o) if (o %in% ops.logic) storage.mode(E) <- "logical" checkIdentical(e, E, sprintf("op: %s, type: %s", o, m)) } } } ### }}} xts vector, matrix/vector xts/inst/unitTests/runit.tclass.R0000644000176200001440000000357313564762102016641 0ustar liggesusers# These tests check the time class attribute is attached to the expected # component of the xts object. The xts constructors should no longer add # 'tclass' or '.indexClass' attributes to the xts object itself. Only the index # should have a 'tclass' attribute. Construct xts objects using structure() to # test behavior when functions encounter xts objects created before 0.10-3. x <- structure(1:5, .Dim = c(5L, 1L), index = structure(1:5, tzone = "", tclass = c("POSIXct", "POSIXt")), .indexCLASS = c("POSIXct", "POSIXt"), tclass = c("POSIXct", "POSIXt"), .indexTZ = "UTC", tzone = "UTC", class = c("xts", "zoo")) test.get_tclass <- function() { checkIdentical(tclass(x), c("POSIXct", "POSIXt")) } test.get_indexClass_warns <- function() { op <- options(warn = 2) on.exit(options(warn = op$warn)) checkException(indexClass(x)) } test.set_indexClass_warns <- function() { op <- options(warn = 2) on.exit(options(warn = op$warn)) checkException(indexClass(x) <- "Date") } test.set_tclass_drops_xts_tclass_indexCLASS <- function() { y <- x tclass(y) <- "POSIXct" checkIdentical(NULL, attr(y, "tclass")) checkIdentical(NULL, attr(y, ".indexCLASS")) } test.set_tclass_changes_index_tclass <- function() { y <- x tclass(y) <- "Date" checkIdentical("Date", attr(attr(y, "index"), "tclass")) } test.get_coredata_drops_xts_tclass_indexCLASS <- function() { y <- coredata(x) checkIdentical(NULL, attr(y, "tclass")) checkIdentical(NULL, attr(y, ".indexCLASS")) } test.get_xtsAttributes_excludes_tclass_indexCLASS <- function() { y <- xtsAttributes(x) checkIdentical(NULL, y$tclass) checkIdentical(NULL, y$.indexCLASS) } test.set_xtsAttributes_removes_tclass_indexClass <- function() { y <- x xtsAttributes(y) <- xtsAttributes(x) checkIdentical(NULL, attr(y, "tclass")) checkIdentical(NULL, attr(y, ".indexCLASS")) } xts/inst/unitTests/runit.zoo.R0000644000176200001440000000350213564762102016147 0ustar liggesusers#sample.zoo <- #structure(c(43.46, 43.3, 43.95, 43.89, 44.01, 43.96, 44.71, 45.02, #45.35, 45.09), .Names = c("264", "263", "262", "261", "260", #"259", "258", "257", "256", "255"), index = structure(c(13516, #13517, 13518, 13521, 13522, 13523, 13524, 13525, 13529, 13530 #), class = "Date"), class = "zoo") # #sample.xts <- #structure(c(43.46, 43.3, 43.95, 43.89, 44.01, 43.96, 44.71, 45.02, #45.35, 45.09), index = structure(c(13516, 13517, 13518, 13521, #13522, 13523, 13524, 13525, 13529, 13530), class = "Date"), class = c("xts", #"zoo"), .CLASS = "zoo", .Dim = c(10L, 1L), .Dimnames = list(c("264", #"263", "262", "261", "260", "259", "258", "257", "256", "255" #), NULL), .ROWNAMES = c("264","263","262", "261", "260", "259", #"258", "257", "256", "255")) # data(sample_matrix) sample.zoo <- zoo(sample_matrix,as.Date(rownames(sample_matrix))) sample.xts <- as.xts(sample.zoo) test.convert_zoo_to_xts <- function() { checkIdentical(sample.xts,as.xts(sample.zoo)) } test.convert_zoo_to_xts_j1 <- function() { checkIdentical(sample.xts[,1],as.xts(sample.zoo)[,1]) } test.convert_zoo_to_xts_i1 <- function() { checkIdentical(sample.xts[1,],as.xts(sample.zoo)[1,]) } test.convert_zoo_to_xts_i1j1 <- function() { checkIdentical(sample.xts[1,1],as.xts(sample.zoo)[1,1]) } test.zoo_reclass <- function() { DEACTIVATED("rownames are not kept yet in current xts-dev") checkIdentical(sample.zoo,reclass(try.xts(sample.zoo))) } test.zoo_reclass_subset_reclass_j1 <- function() { DEACTIVATED("rownames are not kept yet in current xts-dev") checkIdentical(sample.zoo[,1],reclass(try.xts(sample.zoo))[,1]) } test.zoo_reclass_subset_as.xts_j1 <- function() { checkIdentical(sample.zoo[,1],reclass(try.xts(sample.zoo)[,1])) } test.zoo_reclass_subset_zoo_j1 <- function() { checkIdentical(sample.zoo[,1],reclass(try.xts(sample.zoo[,1]))) } xts/inst/unitTests/runit.irts.R0000644000176200001440000000260413564762102016323 0ustar liggesusersif (requireNamespace("tseries", quietly = TRUE)) { # data(sample_matrix) sample.irts <- tseries::irts(as.POSIXct(rownames(sample_matrix)),sample_matrix) sample.irts.xts <- as.xts(sample.irts) test.convert_irts_to_xts <- function() { checkIdentical(sample.irts.xts,as.xts(sample.irts)) } test.convert_irts_to_xts_j1 <- function() { checkIdentical(sample.irts.xts[,1],as.xts(sample.irts)[,1]) } test.convert_irts_to_xts_i1 <- function() { checkIdentical(sample.irts.xts[1,],as.xts(sample.irts)[1,]) } test.convert_irts_to_xts_i1j1 <- function() { checkIdentical(sample.irts.xts[1,1],as.xts(sample.irts)[1,1]) } test.irts_reclass <- function() { DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test") checkIdentical(sample.irts,reclass(try.xts(sample.irts))) } test.irts_reclass_subset_reclass_j1 <- function() { DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test") checkIdentical(sample.irts[,1],reclass(try.xts(sample.irts))[,1]) } test.irts_reclass_subset_as.xts_j1 <- function() { DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test") checkIdentical(sample.irts[,1],reclass(try.xts(sample.irts)[,1])) } test.irts_reclass_subset_irts_j1 <- function() { DEACTIVATED("irts forces rownames, xts disallows rownames. Unable to test") checkIdentical(sample.irts[,1],reclass(try.xts(sample.irts[,1]))) } } # requireNamespace xts/inst/unitTests/runit.period.apply.R0000644000176200001440000000660713564762102017757 0ustar liggesusers# period.apply() doesn't care what generates the INDEX, # but it does care that INDEX has the following characteristics: # 1) the first element is zero, # 2) the last element is nrow(x), # 3) there are no duplicate elements, # 4) the elements are sorted. # test.duplicate_INDEX <- function() { x <- .xts(1:10, 1:10) ep <- c(0, 2, 4, 6, 8, 10) nodup <- period.apply(x, ep, mean) dup <- period.apply(x, c(ep, 10), mean) checkIdentical(nodup, dup) } test.duplicate_INDEX_vector <- function() { x <- 1:10 ep <- c(0, 2, 4, 6, 8, 10) nodup <- period.apply(x, ep, mean) dup <- period.apply(x, c(ep, 10), mean) checkIdentical(nodup, dup) } test.unsorted_INDEX <- function() { x <- .xts(1:10, 1:10) ep.s <- c(2, 4, 6, 8) ep.u <- sample(ep.s) s <- period.apply(x, c(0, ep.s, 10), mean) u <- period.apply(x, c(0, ep.u, 10), mean) checkIdentical(s, u) } test.unsorted_INDEX_vector <- function() { x <- 1:10 ep.s <- c(2, 4, 6, 8) ep.u <- sample(ep.s) s <- period.apply(x, c(0, ep.s, 10), mean) u <- period.apply(x, c(0, ep.u, 10), mean) checkIdentical(s, u) } test.INDEX_starts_with_zero <- function() { x <- .xts(1:10, 1:10) ep <- c(2, 4, 6, 8, 10) a <- period.apply(x, ep, mean) z <- period.apply(x, c(0, ep), mean) checkIdentical(a, z) } test.INDEX_starts_with_zero_vector <- function() { x <- 1:10 ep <- c(2, 4, 6, 8, 10) a <- period.apply(x, ep, mean) z <- period.apply(x, c(0, ep), mean) checkIdentical(a, z) } test.INDEX_ends_with_lengthX <- function() { x <- .xts(1:10, 1:10) ep <- c(0, 2, 4, 6, 8) a <- period.apply(x, ep, mean) z <- period.apply(x, c(ep, 10), mean) checkIdentical(a, z) } test.INDEX_ends_with_lengthX_vector <- function() { x <- 1:10 ep <- c(0, 2, 4, 6, 8) a <- period.apply(x, ep, mean) z <- period.apply(x, c(ep, 10), mean) checkIdentical(a, z) } # check specific period.* functions data(sample_matrix) x <- as.xts(sample_matrix[,1], dateFormat = "Date") e <- endpoints(x, "months") test.period.min_equals_apply.monthly <- function() { # min am <- apply.monthly(x, min) pm <- period.min(x, e) checkEqualsNumeric(am, pm) } test.period.max_equals_apply.monthly <- function() { # max am <- apply.monthly(x, max) pm <- period.max(x, e) checkEqualsNumeric(am, pm) } test.period.sum_equals_apply.monthly <- function() { # sum am <- apply.monthly(x, sum) pm <- period.sum(x, e) checkEqualsNumeric(am, pm) } test.period.prod_equals_apply.monthly <- function() { # prod am <- apply.monthly(x, prod) pm <- period.prod(x, e) checkEqualsNumeric(am, pm) } # test that non-integer INDEX is converted to integer test.period.min_converts_index_to_integer <- function() { storage.mode(e) <- "numeric" pm <- period.min(x, e) } test.period.max_converts_index_to_integer <- function() { storage.mode(e) <- "numeric" pm <- period.max(x, e) } test.period.sum_converts_index_to_integer <- function() { storage.mode(e) <- "numeric" pm <- period.sum(x, e) } test.period.prod_converts_index_to_integer <- function() { storage.mode(e) <- "numeric" pm <- period.prod(x, e) } # test conversion from intraday to daily or lower frequency test.intraday_to_daily <- function() { set.seed(21) i <- as.POSIXct("2013-02-05 01:01", tz = "America/Chicago") x <- xts(rnorm(10000), i - 10000:1 * 60) d <- to.daily(x) dateseq <- seq(as.Date("2013-01-29"), as.Date("2013-02-05"), "day") checkEqualsNumeric(index(d), dateseq) } xts/inst/unitTests/runit.coredata.R0000644000176200001440000000266513564762102017133 0ustar liggesuserstest.coredata_vector <- function() { x <- xts(1, as.Date("2018-03-02")) z <- as.zoo(x) checkIdentical(coredata(x), coredata(z)) } test.coredata_named_vector <- function() { x <- xts(c(hello = 1), as.Date("2018-03-02")) z <- as.zoo(x) checkIdentical(coredata(x), coredata(z)) } test.coredata_matrix <- function() { x <- xts(cbind(1, 9), as.Date("2018-03-02")) z <- as.zoo(x) checkIdentical(coredata(x), coredata(z)) } test.coredata_named_matrix <- function() { x <- xts(cbind(hello = 1, world = 9), as.Date("2018-03-02")) z <- as.zoo(x) checkIdentical(coredata(x), coredata(z)) } test.coredata_data.frame <- function() { x <- xts(data.frame(hello = 1, world = 9), as.Date("2018-03-02")) z <- as.zoo(x) checkIdentical(coredata(x), coredata(z)) } test.coredata_ts <- function() { x <- xts(ts(1), as.Date("2018-03-02")) z <- as.zoo(x) checkIdentical(coredata(x), coredata(z)) } # empty objects test.coredata_empty <- function() { x <- xts(, as.Date("2018-03-02")) z <- as.zoo(x) checkIdentical(coredata(x), coredata(z)) } test.coredata_empty_dim <- function() { x <- xts(cbind(1, 9), as.Date("2018-03-02")) z <- as.zoo(x) x0 <- x[0,] z0 <- z[0,] checkIdentical(coredata(x0), coredata(z0)) } test.coredata_empty_dim_dimnames <- function() { x <- xts(cbind(hello = 1, world = 9), as.Date("2018-03-02")) z <- as.zoo(x) x0 <- x[0,] z0 <- z[0,] checkIdentical(coredata(x0), coredata(z0)) } xts/inst/unitTests/runit.all.equal.R0000644000176200001440000000130713564762102017217 0ustar liggesuserstest.attr_on_object_equal_to_attr_on_index <- function() { # ensure xts objects with index attributes attached are equal to # xts objects with index attributes on the index only attrOnObj <- structure(1:3, index = structure(1:3, tzone = "UTC", tclass = "Date"), class = c("xts", "zoo"), dim = c(3L, 1L), .indexCLASS = "Date", .indexTZ = "UTC", tclass = "Date", tzone = "UTC", dimnames = list(NULL, "x")) attrOnIndex <- structure(1:3, index = structure(1:3, tzone = "UTC", tclass = "Date"), class = c("xts", "zoo"), dim = c(3L, 1L), dimnames = list(NULL, "x")) checkTrue(all.equal(attrOnIndex, attrOnObj)) } xts/inst/unitTests/runit.index.R0000644000176200001440000000152313564771030016450 0ustar liggesuserstest.get_index_does_not_error_if_index_has_no_attributes <- function() { x <- .xts(1:3, 1:3, tzone = "UTC") ix <- index(x) ix <- ix + 3 attr(x, "index") <- 4:6 checkEquals(index(x), ix) } test.set_.index_copies_index_attributes <- function() { x <- .xts(1:3, 1:3, tzone = "UTC") ix <- index(x) ix <- ix + 3 .index(x) <- 4:6 checkEquals(index(x), ix) } test.set_index_copies_index_attributes <- function() { x <- .xts(1:3, 1:3, tzone = "UTC") ix <- index(x) ix <- ix + 3 index(x) <- .POSIXct(4:6, "UTC") checkEquals(index(x), ix) } test.set_index_restores_tzone_attribute <- function() { # x index must be numeric, because index<-.xts coerces RHS to numeric x <- .xts(1:3, 1:3+0, tzone = "") y <- x # Ops.POSIXt drops tzone attribute when tzone = "" index(y) <- index(y) + 0 checkIdentical(x, y) } xts/inst/unitTests/runit.parseISO8601.R0000644000176200001440000000627413564762102017355 0ustar liggesusers# Constants TZ <- "UTC" START_N <- 1424390400 START_T <- .POSIXct(START_N, "UTC") END_N <- 1425168000 END_T <- .POSIXct(1425168000, "UTC") # Test basic functionality for dates (TODO: date-times) test.all_dates <- function() { out <- list(first.time = START_T, last.time = END_T) y <- .parseISO8601("/", START_N, END_N, "UTC") checkIdentical(y, out) y <- .parseISO8601("::", START_N, END_N, "UTC") checkIdentical(y, out) } test.start_to_right_open <- function() { y <- .parseISO8601("2015-02-21/", START_N, END_N, "UTC") start_t <- as.POSIXct("2015-02-21", tz = "UTC") checkIdentical(y, list(first.time = start_t, last.time = END_T)) } test.left_open_to_end <- function() { y <- .parseISO8601("/2015-02-21", START_N, END_N, "UTC") end_t <- as.POSIXct("2015-02-22", tz = "UTC") - 1e-5 checkIdentical(y, list(first.time = START_T, last.time = end_t)) } test.left_open_to_end <- function() { y <- .parseISO8601("/2015-02-21", START_N, END_N, "UTC") end_t <- as.POSIXct("2015-02-22", tz = "UTC") - 1e-5 checkIdentical(y, list(first.time = START_T, last.time = end_t)) } test.single_date <- function() { y <- .parseISO8601("2015-02-21", START_N, END_N, "UTC") start_t <- as.POSIXct("2015-02-21", tz = "UTC") end_t <- as.POSIXct("2015-02-22", tz = "UTC") - 1e-5 checkIdentical(y, list(first.time = start_t, last.time = end_t)) } # Test expected failures # These don't produce errors, but instead return values in UNKNOWN_TIME UNKNOWN_TIME <- list(first.time = NA_real_, last.time = NA_real_) test.start_end_dates_do_not_exist <- function() { x <- "2014-02-30/2015-02-30" y <- .parseISO8601(x, START_N, END_N, "UTC") checkIdentical(y, UNKNOWN_TIME) } test.start_date_does_not_exist <- function() { DEACTIVATED("FAILS: returns everything") x <- "2015-02-30/2015-03-03" y <- .parseISO8601(x, START_N, END_N, "UTC") checkIdentical(y, UNKNOWN_TIME) } test.end_date_does_not_exist <- function() { DEACTIVATED("FAILS: returns everything") x <- "2015-02-25/2015-02-30" y <- .parseISO8601(x, START_N, END_N, "UTC") checkIdentical(y, UNKNOWN_TIME) } # Fuzz tests test.start_end_dates_are_garbage <- function() { x <- "0.21/8601.21" y <- .parseISO8601(x, START_N, END_N, "UTC") checkIdentical(y, UNKNOWN_TIME) } test.start_date_is_garbage <- function() { out <- list(first.time = START_T, last.time = as.POSIXct("2015-02-22", tz = "UTC") - 1e-5) x <- "garbage/2015-02-21" y <- .parseISO8601(x, START_N, END_N, "UTC") checkIdentical(y, out) x <- "0.21/2015-02-21" y <- .parseISO8601(x, START_N, END_N, "UTC") checkIdentical(y, out) } test.end_date_is_garbage <- function() { out <- list(first.time = as.POSIXct("2015-02-25", tz = "UTC"), last.time = END_T) # # ERRORS (uninformative) # x <- "2015-02-25/garbage" # y <- .parseISO8601(x, START_N, END_N, "UTC") # checkIdentical(y, UNKNOWN_TIME) x <- "2015-02-25/8601.21" y <- .parseISO8601(x, START_N, END_N, "UTC") checkIdentical(y, out) } test.single_date_is_garbage <- function() { # # ERRORS (uninformative) # y <- .parseISO8601("garbage", START_N, END_N, "UTC") # checkIdentical(y, UNKNOWN_TIME) y <- .parseISO8601("0.21", START_N, END_N, "UTC") checkIdentical(y, UNKNOWN_TIME) } xts/inst/unitTests/runit.lag.R0000644000176200001440000000211113564762102016076 0ustar liggesusersLAG <- function(x, k=1, na.pad=TRUE) { z <- lag(as.zoo(x), -k, na.pad) dimnames(z) <- NULL as.xts(z) } # POSIXct index test.lag_integer_POSIXt <- function() { x <- .xts(1:5, 1:5 + 0.0) checkIdentical(lag(x), LAG(x)) } test.lag_numeric_POSIXt <- function() { x <- .xts(1:5 + 1.0, 1:5 + 0.0) checkIdentical(lag(x), LAG(x)) } test.lag_logical_POSIXt <- function() { x <- .xts(1:5 > 2, 1:5 + 0.0) checkIdentical(lag(x), LAG(x)) } # Date index test.lag_integer_Date <- function() { x <- xts(1:5, as.Date("2016-01-01") - 5:1) checkIdentical(lag(x), LAG(x)) } test.lag_numeric_Date <- function() { x <- xts(1:5 + 1.0, as.Date("2016-01-01") - 5:1) checkIdentical(lag(x), LAG(x)) } test.lag_logical_Date <- function() { x <- xts(1:5 > 2, as.Date("2016-01-01") - 5:1) checkIdentical(lag(x), LAG(x)) } # Type-check failure errors test.lag_k_NA <- function() { x <- .xts(1:5, 1:5) checkException(lag(x, "a"), "'k' must be integer", TRUE) } test.lag_k_zero_length <- function() { x <- .xts(1:5, 1:5) checkException(lag(x, 1L, "a"), "'na.pad' must be logical", TRUE) } xts/inst/unitTests/runit.indexClass.R0000644000176200001440000001772413564762102017450 0ustar liggesuserswithPackage <- function(pkg, expr) { if (require(pkg, quietly = TRUE, character.only = TRUE)) { pkgpkg <- paste0("package:", pkg) on.exit(detach(pkgpkg, character.only = TRUE), add = TRUE) eval(expr) } } data(sample_matrix) convert_xts <- as.xts(sample_matrix) # indexClass defaults to POSIXct checkUTCindexTZ <- function(x) { if(any(indexClass(x) %in% xts:::.classesWithoutTZ)) { checkIdentical("UTC", attr(.index(x),'tzone')) } } # convert from 'POSIXct' test.convert_POSIXct2Date <- function() { x <- convert_xts indexClass(x) <- 'Date' checkTrue(inherits(index(x),'Date')) checkUTCindexTZ(x) } test.convert_POSIXct2chron <- function() { withPackage("chron", { x <- convert_xts indexClass(x) <- 'chron' checkTrue(inherits(index(x),'dates')) checkUTCindexTZ(x) }) } test.convert_POSIXct2yearmon <- function() { x <- convert_xts indexClass(x) <- 'yearmon' checkTrue(inherits(index(x),'yearmon')) checkUTCindexTZ(x) } test.convert_POSIXct2yearqtr <- function() { x <- convert_xts indexClass(x) <- 'yearqtr' checkTrue(inherits(index(x),'yearqtr')) checkUTCindexTZ(x) } test.convert_POSIXct2timeDate <- function() { withPackage("timeDate", { x <- convert_xts indexClass(x) <- 'timeDate' checkTrue(inherits(index(x),'timeDate')) checkUTCindexTZ(x) }) } test.convert_POSIXct2POSIXct <- function() { x <- convert_xts indexClass(x) <- 'POSIXct' checkTrue(inherits(index(x),'POSIXct')) checkUTCindexTZ(x) } # Convert from 'Date' indexClass(convert_xts) <- 'Date' test.convert_Date2Date <- function() { x <- convert_xts indexClass(x) <- 'Date' checkTrue(inherits(index(x),'Date')) checkUTCindexTZ(x) } test.convert_Date2chron <- function() { withPackage("chron", { x <- convert_xts indexClass(x) <- 'chron' checkTrue(inherits(index(x),'dates')) checkUTCindexTZ(x) }) } test.convert_Date2yearmon <- function() { x <- convert_xts indexClass(x) <- 'yearmon' checkTrue(inherits(index(x),'yearmon')) checkUTCindexTZ(x) } test.convert_Date2yearqtr <- function() { x <- convert_xts indexClass(x) <- 'yearqtr' checkTrue(inherits(index(x),'yearqtr')) checkUTCindexTZ(x) } test.convert_Date2timeDate <- function() { withPackage("timeDate", { x <- convert_xts indexClass(x) <- 'timeDate' checkTrue(inherits(index(x),'timeDate')) checkUTCindexTZ(x) }) } test.convert_Date2POSIXct <- function() { x <- convert_xts indexClass(x) <- 'POSIXct' checkTrue(inherits(index(x),'POSIXct')) checkUTCindexTZ(x) } # Convert from 'chron' if (requireNamespace("chron", quietly = TRUE)) { indexClass(convert_xts) <- 'chron' test.convert_chron2Date <- function() { x <- convert_xts indexClass(x) <- 'Date' checkTrue(inherits(index(x),'Date')) checkUTCindexTZ(x) } test.convert_chron2chron <- function() { withPackage("chron", { x <- convert_xts indexClass(x) <- 'chron' checkTrue(inherits(index(x),'dates')) checkUTCindexTZ(x) }) } test.convert_chron2yearmon <- function() { x <- convert_xts indexClass(x) <- 'yearmon' checkTrue(inherits(index(x),'yearmon')) checkUTCindexTZ(x) } test.convert_chron2yearqtr <- function() { x <- convert_xts indexClass(x) <- 'yearqtr' checkTrue(inherits(index(x),'yearqtr')) checkUTCindexTZ(x) } test.convert_chron2timeDate <- function() { withPackage("timeDate", { x <- convert_xts indexClass(x) <- 'timeDate' checkTrue(inherits(index(x),'timeDate')) checkUTCindexTZ(x) }) } test.convert_chron2POSIXct <- function() { x <- convert_xts indexClass(x) <- 'POSIXct' checkTrue(inherits(index(x),'POSIXct')) checkUTCindexTZ(x) } } # Convert from 'yearmon' indexClass(convert_xts) <- 'yearmon' test.convert_yearmon2Date <- function() { x <- convert_xts indexClass(x) <- 'Date' checkTrue(inherits(index(x),'Date')) checkUTCindexTZ(x) } test.convert_yearmon2chron <- function() { withPackage("chron", { x <- convert_xts indexClass(x) <- 'chron' checkTrue(inherits(index(x),'dates')) checkUTCindexTZ(x) }) } test.convert_yearmon2yearmon <- function() { x <- convert_xts indexClass(x) <- 'yearmon' checkTrue(inherits(index(x),'yearmon')) checkUTCindexTZ(x) } test.convert_yearmon2yearqtr <- function() { x <- convert_xts indexClass(x) <- 'yearqtr' checkTrue(inherits(index(x),'yearqtr')) checkUTCindexTZ(x) } test.convert_yearmon2timeDate <- function() { withPackage("timeDate", { x <- convert_xts indexClass(x) <- 'timeDate' checkTrue(inherits(index(x),'timeDate')) checkUTCindexTZ(x) }) } test.convert_yearmon2POSIXct <- function() { x <- convert_xts indexClass(x) <- 'POSIXct' checkTrue(inherits(index(x),'POSIXct')) checkUTCindexTZ(x) } # Convert from 'yearqtr' indexClass(convert_xts) <- 'yearqtr' test.convert_yearqtr2Date <- function() { x <- convert_xts indexClass(x) <- 'Date' checkTrue(inherits(index(x),'Date')) checkUTCindexTZ(x) } test.convert_yearqtr2chron <- function() { withPackage("chron", { x <- convert_xts indexClass(x) <- 'chron' checkTrue(inherits(index(x),'dates')) checkUTCindexTZ(x) }) } test.convert_yearqtr2yearmon <- function() { x <- convert_xts indexClass(x) <- 'yearmon' checkTrue(inherits(index(x),'yearmon')) checkUTCindexTZ(x) } test.convert_yearqtr2yearqtr <- function() { x <- convert_xts indexClass(x) <- 'yearqtr' checkTrue(inherits(index(x),'yearqtr')) checkUTCindexTZ(x) } test.convert_yearqtr2timeDate <- function() { withPackage("timeDate", { x <- convert_xts indexClass(x) <- 'timeDate' checkTrue(inherits(index(x),'timeDate')) checkUTCindexTZ(x) }) } test.convert_yearqtr2POSIXct <- function() { x <- convert_xts indexClass(x) <- 'POSIXct' checkTrue(inherits(index(x),'POSIXct')) checkUTCindexTZ(x) } # Convert from 'timeDate' if (requireNamespace("timeDate", quietly = TRUE)) { indexClass(convert_xts) <- 'timeDate' test.convert_timeDate2Date <- function() { x <- convert_xts indexClass(x) <- 'Date' checkTrue(inherits(index(x),'Date')) checkUTCindexTZ(x) } test.convert_timeDate2chron <- function() { withPackage("chron", { x <- convert_xts indexClass(x) <- 'chron' checkTrue(inherits(index(x),'dates')) checkUTCindexTZ(x) }) } test.convert_timeDate2yearmon <- function() { x <- convert_xts indexClass(x) <- 'yearmon' checkTrue(inherits(index(x),'yearmon')) checkUTCindexTZ(x) } test.convert_timeDate2yearqtr <- function() { x <- convert_xts indexClass(x) <- 'yearqtr' checkTrue(inherits(index(x),'yearqtr')) checkUTCindexTZ(x) } test.convert_timeDate2timeDate <- function() { withPackage("timeDate", { x <- convert_xts indexClass(x) <- 'timeDate' checkTrue(inherits(index(x),'timeDate')) checkUTCindexTZ(x) }) } test.convert_timeDate2POSIXct <- function() { x <- convert_xts indexClass(x) <- 'POSIXct' checkTrue(inherits(index(x),'POSIXct')) checkUTCindexTZ(x) } } # set index and ensure TZ = "UTC" test.checkUTC_set_index2Date <- function() { x <- .xts(1:2, 1:2) d <- c("2007-01-02", "2007-01-03") index(x) <- as.Date(d) checkUTCindexTZ(x) } test.checkUTC_set_index2chron <- function() { withPackage("chron", { x <- .xts(1:2, 1:2) d <- c("2007-01-02", "2007-01-03") index(x) <- chron::dates(d, format="Y-m-d") checkUTCindexTZ(x) }) } test.checkUTC_set_index2yearmon <- function() { x <- .xts(1:2, 1:2) d <- c("2007-01-02", "2007-01-03") index(x) <- as.yearmon(d) checkUTCindexTZ(x) } test.checkUTC_set_index2yearqtr <- function() { x <- .xts(1:2, 1:2) d <- c("2007-01-02", "2007-01-03") index(x) <- as.yearqtr(d) checkUTCindexTZ(x) } # error checking test.indexClass_NULL <- function() { checkException((indexClass(convert_xts) <- NULL)) } test.indexClass_empty_string <- function() { checkException((indexClass(convert_xts) <- '')) } test.indexClass_full_index <- function() { checkException((indexClass(convert_xts) <- index(convert_xts))) } test.indexClass_unquoted_symbol <- function() { withPackage("timeDate", { checkException((indexClass(convert_xts) <- timeDate)) }) } test.indexClass_missing_object <- function() { rm(Date) checkException((indexClass(convert_xts) <- Date)) } xts/inst/unitTests/runit.to.period.R0000644000176200001440000000061613564762102017246 0ustar liggesusers# ensure first group is included in output test.to.frequency_includes_first_group <- function() { data(sample_matrix) x <- as.xts(sample_matrix) x$Volume <- 1 tf <- xts:::to.frequency(x, x$Volume, 90, name=NULL) tp <- .Call("toPeriod", x, c(0L, 90L, 180L), TRUE, 5L, FALSE, FALSE, c("Open", "High", "Low", "Close", "Volume") , PACKAGE="xts") checkIdentical(tf, tp) } xts/inst/unitTests/runit.ts.R0000644000176200001440000000563013564762102015772 0ustar liggesusersdata(sample_matrix) sample.ts1 <- ts(sample_matrix,start=as.numeric(as.Date(rownames(sample_matrix)[1]))) sample.xts.ts1 <- as.xts(sample.ts1) test.convert_ts_to_xts <- function() { checkIdentical(sample.xts.ts1,as.xts(sample.ts1)) } test.convert_ts_to_xts_j1 <- function() { checkIdentical(sample.xts.ts1[,1],as.xts(sample.ts1)[,1]) } test.convert_ts_to_xts_i1 <- function() { checkIdentical(sample.xts.ts1[1,],as.xts(sample.ts1)[1,]) } test.convert_ts_to_xts_i1j1 <- function() { checkIdentical(sample.xts.ts1[1,1],as.xts(sample.ts1)[1,1]) } test.ts_reclass <- function() { checkIdentical(sample.ts1,reclass(try.xts(sample.ts1))) } test.ts_reclass_subset_reclass_j1 <- function() { checkIdentical(sample.ts1[,1],reclass(try.xts(sample.ts1))[,1]) } test.ts_reclass_subset_as.xts_j1 <- function() { checkIdentical(sample.ts1[,1],reclass(try.xts(sample.ts1)[,1])) } test.ts_reclass_subset_ts_j1 <- function() { checkIdentical(sample.ts1[,1],reclass(try.xts(sample.ts1[,1]))) } # quarterly series sample.ts4 <- ts(sample_matrix,start=1960,frequency=4) sample.xts.ts4 <- as.xts(sample.ts4) test.convert_ts4_to_xts <- function() { checkIdentical(sample.xts.ts4,as.xts(sample.ts4)) } test.convert_ts4_to_xts_j1 <- function() { checkIdentical(sample.xts.ts4[,1],as.xts(sample.ts4)[,1]) } test.convert_ts4_to_xts_i1 <- function() { checkIdentical(sample.xts.ts4[1,],as.xts(sample.ts4)[1,]) } test.convert_ts4_to_xts_i1j1 <- function() { checkIdentical(sample.xts.ts4[1,1],as.xts(sample.ts4)[1,1]) } test.ts4_reclass <- function() { checkIdentical(sample.ts4,reclass(try.xts(sample.ts4))) } test.ts4_reclass_subset_reclass_j1 <- function() { checkIdentical(sample.ts4[,1],reclass(try.xts(sample.ts4))[,1]) } test.ts4_reclass_subset_as.xts_j1 <- function() { checkIdentical(sample.ts4[,1],reclass(try.xts(sample.ts4)[,1])) } test.ts4_reclass_subset_ts_j1 <- function() { checkIdentical(sample.ts4[,1],reclass(try.xts(sample.ts4[,1]))) } # monthly series sample.ts12 <- ts(sample_matrix,start=1990,frequency=12) sample.xts.ts12 <- as.xts(sample.ts12) test.convert_ts12_to_xts <- function() { checkIdentical(sample.xts.ts12,as.xts(sample.ts12)) } test.convert_ts12_to_xts_j1 <- function() { checkIdentical(sample.xts.ts12[,1],as.xts(sample.ts12)[,1]) } test.convert_ts12_to_xts_i1 <- function() { checkIdentical(sample.xts.ts12[1,],as.xts(sample.ts12)[1,]) } test.convert_ts12_to_xts_i1j1 <- function() { checkIdentical(sample.xts.ts12[1,1],as.xts(sample.ts12)[1,1]) } test.ts12_reclass <- function() { checkIdentical(sample.ts12,reclass(try.xts(sample.ts12))) } test.ts12_reclass_subset_reclass_j1 <- function() { checkIdentical(sample.ts12[,1],reclass(try.xts(sample.ts12))[,1]) } test.ts12_reclass_subset_as.xts_j1 <- function() { checkIdentical(sample.ts12[,1],reclass(try.xts(sample.ts12)[,1])) } test.ts12_reclass_subset_ts_j1 <- function() { checkIdentical(sample.ts12[,1],reclass(try.xts(sample.ts12[,1]))) } xts/inst/unitTests/runit.fts.R0000644000176200001440000000633313564762102016141 0ustar liggesusersif (requireNamespace("fts", quietly = TRUE)) { data(sample_matrix) sample.fts1 <- ts(sample_matrix,start=as.Date(rownames(sample_matrix)[1])) sample.fts1 <- fts::fts(index(sample.fts1), sample_matrix) sample.xts.fts1 <- as.xts(sample.fts1) test.convert_fts_to_xts <- function() { checkIdentical(sample.xts.fts1,as.xts(sample.fts1)) } test.convert_fts_to_xts_j1 <- function() { checkIdentical(sample.xts.fts1[,1],as.xts(sample.fts1)[,1]) } test.convert_fts_to_xts_i1 <- function() { checkIdentical(sample.xts.fts1[1,],as.xts(sample.fts1)[1,]) } test.convert_fts_to_xts_i1j1 <- function() { checkIdentical(sample.xts.fts1[1,1],as.xts(sample.fts1)[1,1]) } test.fts_reclass <- function() { checkIdentical(sample.fts1,reclass(try.xts(sample.fts1))) } test.fts_reclass_subset_reclass_j1 <- function() { checkIdentical(sample.fts1[,1],reclass(try.xts(sample.fts1))[,1]) } test.fts_reclass_subset_as.xts_j1 <- function() { checkIdentical(sample.fts1[,1],reclass(try.xts(sample.fts1)[,1])) } test.fts_reclass_subset_fts_j1 <- function() { checkIdentical(sample.fts1[,1],reclass(try.xts(sample.fts1[,1]))) } # quarterly series sample.fts4 <- ts(sample_matrix,start=1960,frequency=4) sample.fts4 <- fts::fts(index(sample.fts4), sample_matrix) sample.xts.fts4 <- as.xts(sample.fts4) test.convert_fts4_to_xts <- function() { checkIdentical(sample.xts.fts4,as.xts(sample.fts4)) } test.convert_fts4_to_xts_j1 <- function() { checkIdentical(sample.xts.fts4[,1],as.xts(sample.fts4)[,1]) } test.convert_fts4_to_xts_i1 <- function() { checkIdentical(sample.xts.fts4[1,],as.xts(sample.fts4)[1,]) } test.convert_fts4_to_xts_i1j1 <- function() { checkIdentical(sample.xts.fts4[1,1],as.xts(sample.fts4)[1,1]) } test.fts4_reclass <- function() { checkIdentical(sample.fts4,reclass(try.xts(sample.fts4))) } test.fts4_reclass_subset_reclass_j1 <- function() { checkIdentical(sample.fts4[,1],reclass(try.xts(sample.fts4))[,1]) } test.fts4_reclass_subset_as.xts_j1 <- function() { checkIdentical(sample.fts4[,1],reclass(try.xts(sample.fts4)[,1])) } test.fts4_reclass_subset_fts_j1 <- function() { checkIdentical(sample.fts4[,1],reclass(try.xts(sample.fts4[,1]))) } # monthly series sample.fts12 <- ts(sample_matrix,start=1990,frequency=12) sample.fts12 <- fts::fts(index(sample.fts12), sample_matrix) sample.xts.fts12 <- as.xts(sample.fts12) test.convert_fts12_to_xts <- function() { checkIdentical(sample.xts.fts12,as.xts(sample.fts12)) } test.convert_fts12_to_xts_j1 <- function() { checkIdentical(sample.xts.fts12[,1],as.xts(sample.fts12)[,1]) } test.convert_fts12_to_xts_i1 <- function() { checkIdentical(sample.xts.fts12[1,],as.xts(sample.fts12)[1,]) } test.convert_fts12_to_xts_i1j1 <- function() { checkIdentical(sample.xts.fts12[1,1],as.xts(sample.fts12)[1,1]) } test.fts12_reclass <- function() { checkIdentical(sample.fts12,reclass(try.xts(sample.fts12))) } test.fts12_reclass_subset_reclass_j1 <- function() { checkIdentical(sample.fts12[,1],reclass(try.xts(sample.fts12))[,1]) } test.fts12_reclass_subset_as.xfts_j1 <- function() { checkIdentical(sample.fts12[,1],reclass(try.xts(sample.fts12)[,1])) } test.fts12_reclass_subset_fts_j1 <- function() { checkIdentical(sample.fts12[,1],reclass(try.xts(sample.fts12[,1]))) } } # requireNamespace xts/inst/unitTests/runit.matrix.R0000644000176200001440000000303313564762102016643 0ustar liggesusersdata(sample_matrix) sample.matrix <- sample_matrix sample.xts <- as.xts(sample.matrix) test.convert_matrix_to_xts <- function() { checkIdentical(sample.xts,as.xts(sample.matrix)) } test.convert_matrix_to_xts_j1 <- function() { checkIdentical(sample.xts[,1],as.xts(sample.matrix)[,1]) } test.convert_matrix_to_xts_i1 <- function() { checkIdentical(sample.xts[1,],as.xts(sample.matrix)[1,]) } test.convert_matrix_to_xts_i1j1 <- function() { checkIdentical(sample.xts[1,1],as.xts(sample.matrix)[1,1]) } test.matrix_reclass <- function() { checkIdentical(sample.matrix,reclass(try.xts(sample.matrix))) } test.matrix_reclass_subset_reclass_j1 <- function() { checkIdentical(sample.matrix[,1],reclass(try.xts(sample.matrix))[,1]) } test.matrix_reclass_subset_as.xts_j1 <- function() { checkIdentical(sample.matrix[,1,drop=FALSE],reclass(try.xts(sample.matrix)[,1])) checkIdentical(sample.matrix[,1],reclass(try.xts(sample.matrix))[,1]) } test.matrix_reclass_subset_matrix_j1 <- function() { checkIdentical(sample.matrix[,1,drop=FALSE],reclass(try.xts(sample.matrix[,1,drop=FALSE]))) } # zero-width to matrix test.zero_width_xts_to_matrix <- function() { x <- .xts(,1) xm <- as.matrix(x) zm <- as.matrix(as.zoo(x)) checkIdentical(xm, zm) } # dim-less xts to matrix test.dimless_xts_to_matrix <- function() { ix <- structure(1:3, tclass = c("POSIXct", "POSIXt"), tzone = "") x <- structure(1:3, index = ix, class = c("xts", "zoo")) m <- matrix(1:3, 3, 1, dimnames = list(format(.POSIXct(1:3)), "x")) checkIdentical(as.matrix(x), m) }