Nothing
################################################################################
##
## $Id: matchedPortfolio.R 404 2007-04-19 16:27:55Z enos $
##
## Basic matchedPortfolio class.
##
## This matchedPortfolio class represents an "original" portfolioBasic that
## has been matched with one or more portfolios according to a specified
## formula.
##
## For simplicity I've included methods on matchedPortfolioCollection
## here as well, but should really be separated.
##
################################################################################
setMethod("show",
signature(object = "matchedPortfolio"),
function(object){
## displays essential information
plural <- ifelse(ncol(object@matches) > 1, "s", "")
cat("An object of class \"matchedPortfolio\":\n\n",
"slots:\n\n", sep = "")
cat("formula: "); print(object@formula); cat("\n\n")
cat("original:\n",
sprintf(" %i %s", nrow(object@original@weights),
"positions."), "\n",
sprintf(" %.3f %s", performance(object@original)@ret,
object@original@ret.var), "\n\n"
)
cat(paste("matches:", sep = ""), "\n",
sprintf(" %i %s",
nrow(object@matches),
"positions."), "\n",
sprintf(" %i %s%s", ncol(object@matches),
"matched portfolio", plural), "\n",
sprintf(" %.3f %s", totalReturn(object),
object@original@ret.var), "\n\n"
)
cat("Difference in returns:", performance(object@original)@ret
- totalReturn(object), "\n")
}
)
setMethod("summary",
signature(object = "matchedPortfolio"),
function(object){
## Really need to refactor this .orig.perf function
## business.
orig.perf <- performance(object@original)@ret
all.matched.perf <- totalReturn(object, output = "individual")
matched.perf <- mean(all.matched.perf, na.rm = TRUE)
perf.ranks <- rank(c(orig.perf, all.matched.perf[!is.na(all.matched.perf)]))
percentile <- perf.ranks[1] / length(perf.ranks)
cat("Matched portfolio summary: ", object@original@name, "\n\n",
ncol(object@matches), " matches using ", object@method, " matching.\n\n",
"Matched portfolio returns:\n",
sep = "")
print(summary(all.matched.perf))
cat("\n",
"Original portfolio return: ", format(orig.perf),
", with ", performance(object@original)@missing.return, " NAs.\n",
"Original return relative to matches: ", format(orig.perf - matched.perf), "\n\n",
"Original portfolio outperformed ", format(round(100 * percentile)), "% of matches.\n",
sep = ""
)
}
)
## Do I really need this method?
setMethod("totalReturn",
signature(object = "matchedPortfolio"),
function(object, output = "pooled"){
## "output" is the format for returning performance. The
## options are "pooled" and "individual". "pooled"
## returns a scalar, the mean of the returns for all
## matched portfolios. "individual" returns a vector of
## the returns for each portfolio
stopifnot(validObject(object))
stopifnot(output %in% c("individual", "pooled"))
res <-
sapply(data.frame(object@matches),
function(x){
sum(object@original@weights$weight[match(row.names(object@matches), object@original@weights$id)] *
object@original@data[[object@original@ret.var]][match(x, object@original@data$id)]) })
# ## "matches" is a weight matrix. "returns" is a vector of
# ## returns. "output" is either "individual" or "pooled" and
# ## specifies whether to return a vector of the returns for each
# ## matched portfolio or the mean return
# matches <- object@matches
# returns <-
# object@original@data[[object@original@ret.var]][match(rownames(matches),
# object@original@data$id)]
# ## calculates returns for each stock
# res <- apply(matches, 2, function(x){x * returns})
# ## calculates sum for each matched portfolio
# res <- apply(res, 2, sum, na.rm = TRUE)
if(identical(output, "pooled")){
res <- mean(res, na.rm = TRUE)
}
invisible(res)
}
)
setMethod("performance",
signature(object = "matchedPortfolio"),
function(object){
invisible(totalReturn(object, output = "individual"))
}
)
setMethod("contribution",
signature(object = "matchedPortfolio", contrib.var = "character"),
function(object, contrib.var, buckets = 5){
}
)
setMethod("exposure",
signature(object = "matchedPortfolio", exp.var = "character"),
function(object, exp.var, output = "pooled"){
## "exp.var" is a vector of variables on which to
## calculate exposure. The "data" slot of the "original"
## portfolio must contain a column for every value in
## "exp.var". Returns a list where each element in the
## list is the name of an element in "exp.var".
stopifnot(validObject(object))
## Right now, only allow a single exposure variable that's
## numeric.
data <- object@original@data
## Cannot calculate performance if there are no "exp.var"
## values. "data" must contain information for at least 1
## stock.
stopifnot(
length(exp.var) > 0,
nrow(data) > 0,
all(exp.var %in% names(data))
)
exp.list <- list()
## Construct weight vector for matches:
weight.matches <- object@original@weights$weight[match(row.names(object@matches),
object@original@weights$id)]
## calculates exposures for all elements of "exp.var"
for(ev in exp.var){
## 2007-04-17: This is screwed up, because the handling
## of numeric and character/factor exposures should be
## the same for different output types. As I look at
## this now, there is no notion of "pooled" for numeric
## exposures; furthermore, use of colMeans here was
## incorrect and produced wrong result. Now I use
## colSums correctly, but multiple results will always
## be returned for matched portfolios with more than one
## match.
if(is.numeric(data[[ev]])){ ## numeric variables
exp <- apply(object@matches, 2, function(x){
weight.matches * data[[ev]][match(x, data$id)]})
exp.list[[ev]] <- colSums(exp)
}
else if(is.character(data[[ev]]) || is.factor(data[[ev]])){ # character variables
## builds a matrix to store the results of each call
## to "tapply". "matrix" contains as many rows as
## their are matched portfolios and as many columns as
## there are levels of the current exposure variable,
## "ev"
exp <- matrix(0,
nrow = dim(object@matches)[[2]],
ncol = length(levels(data[[ev]])),
dimnames = list(1:dim(object@matches)[[2]],
levels(data[[ev]])[order(levels(data[[ev]]))])
)
for(i in 1:ncol(object@matches)){
exp[i,] <- tapply(weight.matches, data[[ev]][match(object@matches[,i], data$id)], sum,
simplify = TRUE)
## Make NA's 0 to make this old code work.
exp[i,is.na(exp[i,])] <- 0
}
if(identical(output, "pooled")){
exp <- colMeans(exp)
}
exp.list[[ev]] <- exp
}
}
exp.list
}
)
setMethod("plot",
signature(x = "matchedPortfolio", y = "missing"),
function(x, type = "returns"){
data <- .matched.perf.df(x)
panel <- function(x, subscripts, ...){
panel.histogram(x, ...)
data.sub <- data[subscripts, , drop = FALSE]
stopifnot(sum(!data.sub$match) == 1)
orig.ret <- data.sub$return[!data.sub$match]
percentile <- round(100 * rank(data.sub$return)[!data.sub$match] / max(rank(data.sub$return)))
grid.segments(x0 = unit(orig.ret, "native"), y0 = unit(0, "native"),
x1 = unit(orig.ret, "native"), y1 = unit(1, "npc"),
gp = gpar(lty = "dashed"))
grid.text(paste(format(percentile), "% ", sep = ""),
x = unit(orig.ret, "native"), y = unit(1, "npc") - unit(1, "lines"),
just = "right", gp = gpar(cex = 0.8))
# grid.text(paste(" ", format(100 - percentile), "%", sep = ""),
# x = unit(orig.ret, "native"), y = unit(1, "npc") - unit(1, "lines"),
# just = "left", gp = gpar(cex = 0.8))
}
main <- paste(x@original@name, "vs. matched portfolios")
histogram( ~ return, data = data, panel = panel, nint = 50, type = "percent", main = main)
}
)
################################################################################
##
## Helper/utility functions
##
################################################################################
## .matched.perf.df
##
## Helper function that collects performance and summary info for a
## matchedPortfolio object. elements of the collection
.matched.perf.df <- function(object){
stopifnot(is(object, "matchedPortfolio"))
exp.orig <- sum(object@original@weights$weight, na.rm = TRUE)
num.orig <- sum(!is.na(object@original@weights$weight))
## All the matches should have the same total net exposure, and
## should only differ from the net exposure of the original
## portfolio by omitted positions. Only break if there don't appear
## to be any matches at all.
stopifnot(nrow(object@matches) > 0)
exp.match <- sum(object@original@weights$weight[match(row.names(object@matches),
object@original@weights$id)])
num.match <- nrow(object@matches)
data <- rbind(data.frame(match = FALSE, return = performance(object@original)@ret,
omitted.treatment = object@omitted.treatment,
omitted.control = object@omitted.control,
exposure = exp.orig, num = num.orig
),
data.frame(match = TRUE, return = totalReturn(object, output = "individual"),
omitted.treatment = NA, omitted.control = NA,
exposure = exp.match, num = num.match
))
invisible(data)
}
.match.as.portfolioBasic <- function(object, match.num){
stopifnot(is(object, "matchedPortfolio"),
match.num <= ncol(object@matches))
weights <- object@original@weights
weights$id <- object@matches[,match.num][match(weights$id,
row.names(object@matches))]
row.names(weights) <- weights$id
p <- new("portfolioBasic", data = object@original@data, symbol.var = "symbol")
p@weights <- weights
p
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.