Nothing
################################################################################
##
## $Id: map.market.R 1327 2009-06-11 13:14:09Z enos $
##
## Plot a "map" of a given portfolio, based on the Map of the Market
##
################################################################################
## The parameters "id", "area", "group", and "color" must be vectors
## of the same length. "id" stores the labels for each stock. "area"
## stores the values used to compute the area of rectangles in the
## map. "group" stores the group of each stock. "color" stores the
## values used to compute the color of the rectangles. "lab"
## specifies whether labels should be printed; the default is to print
## group labels, but not stock labels. "scale" specifies the number
## of units away from zero that will be represented by the color. All
## values for color outside of this range will appear the same. If
## null, the most extreme value for color is used. "print" is a
## logical specifying whether the map should be drawn.
map.market <- function(id, area, group, color,
scale = NULL,
lab = c("group"=TRUE, "id"=FALSE),
main = "Map of the Market",
print = TRUE
){
if(any(length(id) != length(area),
length(id) != length(group),
length(id) != length(color))){
stop("id, area, group, and color must be the same length.")
}
## If only one logical given for "lab", use for both group and stock
## labels
if(length(lab) == 1){
lab[2] <- lab[1]
}
## If 'id' parameter not specified create sequential ids
if (missing(id)) {
id <- seq_along(area)
lab["id"] <- FALSE
}
## NA values in the id parameter are not allowed.
stopifnot(all(!is.na(id)))
## Collect the input vectors in a data.frame.
data <- data.frame(label = id, group, area, color)
data <- data[order(data$area, decreasing = TRUE),]
## area, group and color need to be non-NA for a record to be
## included in the viz.
na.idx <- which(is.na(data$area) | is.na(data$group) | is.na(data$color))
if(length(na.idx)){
warning("Stocks with NAs for area, group, or color will not be shown")
data <- data[-na.idx, ]
}
## Remove records with zero areas
zero.area.idx <- which(data$area == 0)
if(length(zero.area.idx)) {
data <- data[-zero.area.idx, ]
}
## If no records pass the above criteria, stop.
if(nrow(data) == 0){
stop("No records to display")
}
## If no color divisor is specified, map the values in 'color' to
## the interval [0,1], maintaining spacing. Otherwise, divide by
## the supplied scaling factor.
data$color.orig <- data$color
if(is.null(scale)){
data$color <- data$color * 1/max(abs(data$color))
}
else{
data$color <- sapply(data$color, function(x) {if(x/scale > 1) 1 else if(-1 > x/scale) -1 else x/scale})
}
## Start dividing data up into groups.
data.by.group <- split(data, data$group, drop = TRUE)
group.data <- lapply(data.by.group, function(x){sum(x[,3])})
group.data <- data.frame(area = as.numeric(group.data),
label = names(group.data))
group.data <- group.data[order(group.data$area, decreasing=TRUE),]
group.data$color <- rep(NULL, nrow(group.data))
## Two color gradient functions to map [-1,0] to [red, black] and
## [0,1] to [black, green].
color.ramp.pos <- grDevices::colorRamp(c("black", "green"))
color.ramp.neg <- grDevices::colorRamp(c("black", "red"))
## Map a vector with values in [-1,1] to a vector of rgb colors.
color.ramp.rgb <- function(x){
col.mat <- mapply(
function(x){
if(x < 0){
color.ramp.neg(abs(x))
}
else{
color.ramp.pos(abs(x))
}
},
x)
mapply(grDevices::rgb, col.mat[1,], col.mat[2,], col.mat[3,], max = 255)
}
## Accepts the current viewport list and parameters for the next viewport
## Returns the viewport list with the next viewport appended to it.
add.viewport <- function(z, label, color, x.0, y.0, x.1, y.1){
for(i in 1:length(label)){
## Groups are transparent, positive change is green, negative
## change is red.
if(is.null(color[i])){
filler <- gpar(col="blue", fill="transparent", cex = 1)
}
else{
filler.col <- color.ramp.rgb(color[i])
filler <- gpar(col = filler.col, fill = filler.col, cex = 0.6)
}
## Viewport created from squarified treemap specifications
new.viewport <- viewport(x = x.0[i],
y = y.0[i],
width = (x.1[i] - x.0[i]),
height = (y.1[i] - y.0[i]),
default.units = "npc",
just = c("left", "bottom"),
name = as.character(label[i]),
clip = "on", gp = filler)
z <- append(z, list(new.viewport))
}
z
}
## Recursive function that returns a complete list of viewports, in
## the order they should be plotted. "z" should be a data frame
## with columns "area", "label", and "color", sorted in descending
## order by "z$area"; "viewport.list" should be an initially empty
## list; func should be the "add.viewport" function defined above
squarified.treemap <- function(z, x = 0, y = 0, w = 1, h = 1,
func = add.viewport, viewport.list){
## "cz" stores cumulative percentages of the total area
cz <- cumsum(z$area) / sum(z$area)
## "n" marks where to break this region
n <- which.min(abs(log(max(w/h, h/w) * sum(z$area) * ((cz^2)/z$area))))
## do we have any left-over rectangles?
more <- n < length(z$area)
## "a" stores cumulative percentages for this region
a <- c(0, cz[1:n]) / cz[n]
## Determines the direction in which we are adding rectangles
if (h > w){
## Calls the add.viewport function n times, adding each
## rectangle to "viewport.list"
viewport.list <- func(viewport.list, z$label[1:n], z$color[1:n],
x+w*a[1:(length(a)-1)], rep(y,n), x+w*a[-1],
rep(y+h*cz[n],n))
## Recursive call, in case there are more regions
if(more){
viewport.list <- Recall(z[-(1:n), ], x, y+h*cz[n], w, h*(1-cz[n]),
func, viewport.list)
}
}
else{
viewport.list <- func(viewport.list, z$label[1:n], z$color[1:n],
rep(x,n), y+h*a[1:(length(a)-1)],
rep(x+w*cz[n],n), y+h*a[-1])
if(more){
viewport.list <- Recall(z[-(1:n), ], x+w*cz[n], y, w*(1-cz[n]),
h, func, viewport.list)
}
}
viewport.list
}
## Create gTree representing the actual map of the market
map.viewport <- viewport(x = 0.05, y = 0.05, width = 0.9, height = 0.75,
default.units = "npc", name = "MAP",
just = c("left", "bottom"))
map.tree <- gTree(vp = map.viewport, name = "MAP",
children = gList(rectGrob(gp = gpar(col = "dark grey"),
name = "background")))
## Get viewports for each group
group.viewports <- squarified.treemap(z = group.data,
viewport.list = list())
## For each group, create gTree for the group and get viewports for
## the stocks in that group.
for(i in 1:length(group.viewports)){
this.group <- data.by.group[[group.data$label[i]]]
this.data <- data.frame(this.group$area, this.group$label,
this.group$color)
names(this.data) <- c("area", "label", "color")
stock.viewports <- squarified.treemap(z = this.data, viewport.list = list())
group.tree <- gTree(vp = group.viewports[[i]], name = group.data$label[i])
## For each stock in the current group, create a gTree and add it
## to the group gTree
for(s in 1:length(stock.viewports)){
stock.tree <- gTree(vp = stock.viewports[[s]], name = this.data$label[s],
children = gList(rectGrob(name = "color")))
if(lab[2]){
stock.tree <- addGrob(stock.tree, textGrob(
x = unit(1, "lines"), y = unit(1, "npc") - unit(1, "lines"),
label = this.data$label[s],
gp = gpar(col = "white"),
name = "label",
just = c("left", "top")
))
}
group.tree <- addGrob(group.tree, stock.tree)
}
## Add border and label grobs to group gTree
group.tree <- addGrob(group.tree, rectGrob(gp = gpar(col = "grey"),
name = "border"))
if(lab[1]){
group.tree <- addGrob(group.tree, textGrob(label = group.data$label[i],
name = "label", gp = gpar(col = "white")))
}
## Add group gTree to map gTree
map.tree <- addGrob(map.tree, group.tree)
}
## Create gTree to represent top
op <- options(digits = 1)
top.viewport <- viewport(x = 0.05, y = 1, width = 0.9, height = 0.20,
default.units = "npc", name = "TOP",,
just = c("left", "top"))
legend.ncols <- 51
l.x <- (0:(legend.ncols-1))/(legend.ncols)
l.y <- unit(0.25, "npc")
l.cols <- color.ramp.rgb(seq(-1, 1, by = 2/(legend.ncols-1)))
if(is.null(scale)){
l.end <- max(abs(data$color.orig))
}
else{
l.end <- scale
}
top.list <-
gList(textGrob(label = main, y = unit(0.7, "npc"),
just = c("center", "center"), gp = gpar(cex = 2)),
segmentsGrob(x0 = seq(0, 1, by = 0.25), y0 = unit(0.25, "npc"),
x1 = seq(0, 1, by = 0.25), y1 = unit(0.2, "npc")),
rectGrob(x = l.x, y = l.y,
width = 1/legend.ncols, height = unit(1, "lines"),
just = c("left","bottom"),
gp = gpar(col = NA, fill = l.cols),
default.units = "npc"),
textGrob(label = format(l.end * seq(-1, 1, by = 0.5), trim = TRUE),
x = seq(0, 1, by = 0.25), y = 0.1,
default.units = "npc",
just = c("center", "center"),
gp = gpar(col = "black", cex = 0.8, fontface = "bold")))
options(op)
top.tree <- gTree(vp = top.viewport, name = "TOP",
children = top.list)
## Put map and top gTrees together
mapmarket <- gTree(name = "MAPMARKET", children = gList(
rectGrob(gp=gpar(col="dark grey",
fill="dark grey"),
name = "background"),
top.tree,
map.tree
))
## Print and return
if(print){
grid.newpage()
grid.draw(mapmarket)
}
invisible(mapmarket)
}
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.