#
# 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 <http://www.gnu.org/licenses/>.
merge.xts <- function(...,
all=TRUE,
fill=NA,
suffixes=NULL,
join="outer",
retside=TRUE,
retclass="xts",
tzone=NULL,
drop=NULL,
check.names=NULL) {
if(is.null(check.names)) {
check.names <- TRUE
}
if(is.logical(retclass) && !retclass) {
setclass=FALSE
} else setclass <- TRUE
fill.fun <- NULL
if(is.function(fill)) {
fill.fun <- fill
fill <- NA
}
# as.list(substitute(list(...))) # this is how zoo handles colnames - jar
mc <- match.call(expand.dots=FALSE)
dots <- mc$...
if(is.null(suffixes)) {
syms <- names(dots)
if(is.null(syms)) {
# Based on makeNames() in merge.zoo()
syms <- substitute(alist(...))[-1L]
nm <- names(syms)
fixup <- if (is.null(nm)) seq_along(syms) else !nzchar(nm)
dep <- sapply(syms[fixup], function(x) deparse(x, nlines = 1L))
if(is.null(nm)) {
nm <- dep
} else if(any(fixup)) {
nm[fixup] <- dep
}
syms <- nm
} else {
have.symnames <- nzchar(syms)
if(any(!have.symnames)) {
syms[!have.symnames] <- as.character(dots[!have.symnames])
}
}
} else
if(length(suffixes) != length(dots)) {
warning("length of suffixes and does not match number of merged objects")
syms <- as.character(dots)
# should we ignore suffixes here?
#suffixes <- NULL
} else {
syms <- as.character(suffixes)
}
.times <- .External(C_number_of_cols, ...)
# moved call to make.names inside of mergeXts/do_merge_xts
symnames <- rep(syms, .times)
suffixes <- rep(suffixes, .times)
if(length(dots) == 1) {
# this is for compat with zoo; one object AND a name
if(!is.null(names(dots))) {
x <- list(...)[[1]]
if(is.null(colnames(x)))
colnames(x) <- symnames
return(x)
}
}
if( !missing(join) ) {
# join logic applied to index:
# inspired by: http://blogs.msdn.com/craigfr/archive/2006/08/03/687584.aspx
#
# (full) outer - all cases, equivelant to all=c(TRUE,TRUE)
# left - all x, && y's that match x
# right - all ,y && x's that match y
# inner - only x and y where index(x)==index(y)
all <- switch(pmatch(join,c("outer","left","right","inner")),
c(TRUE, TRUE ), # outer
c(TRUE, FALSE), # left
c(FALSE, TRUE ), # right
c(FALSE, FALSE) # inner
)
if( length(dots) > 2 ) {
all <- all[1]
warning("'join' only applicable to two object merges")
}
}
if( length(all) != 2 ) {
if( length(all) > 2 )
warning("'all' must be of length two")
all <- rep(all[1], 2)
}
if( length(dots) > 2 )
retside <- TRUE
if( length(retside) != 2 )
retside <- rep(retside[1], 2)
x <- .External(C_mergeXts,
all=all[1:2],
fill=fill,
setclass=setclass,
symnames=symnames,
suffixes=suffixes,
retside=retside,
env=new.env(),
tzone=tzone,
check.names=check.names,
...)
if(!is.logical(retclass) && retclass != 'xts') {
asFun <- paste("as", retclass, sep=".")
if(!exists(asFun)) {
warning(paste("could not locate",asFun,"returning 'xts' object instead"))
return(x)
}
xx <- try(do.call(asFun, list(x)))
if(!inherits(xx,'try-error')) {
return(xx)
}
}
if(!is.null(fill.fun)) {
fill.fun(x)
} else
return(x)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.