# 小提琴图：展示数据密度分布的工具

### 谢益辉 / 2008-10-31

library(UsingR)
violin.colors = function(x, ..., orientation = "vertical",
bw = "nrd0", names = NULL, from = NULL, to = from, pars = NULL,
col = NA) {
args <- list(x, ...)
namedargs <- if (!is.null(attributes(args)$names)) attributes(args)$names != ""
else rep(FALSE, length = length(args))
pars <- c(args[namedargs], pars)
groups <- if (is.list(x))
x
else args[!namedargs]
if (0 == (n <- length(groups)))
stop("invalid first argument")
if (length(class(groups)))
groups <- unclass(groups)
if (!missing(names))
attr(groups, "names") <- names
else {
if (is.null(attr(groups, "names")))
attr(groups, "names") <- 1:n
names <- attr(groups, "names")
}
xvals <- matrix(0, nr = 512, nc = n)
yvals <- matrix(0, nr = 512, nc = n)
center <- 1:n
for (i in 1:n) {
if (is.null(from))
tmp.dens <- density(groups[[i]], bw = bw)
else tmp.dens <- density(groups[[i]], bw = bw, from = from,
to = to)
xvals[, i] <- tmp.dens$x yvals.needtoscale <- tmp.dens$y
yvals.scaled <- 7/16 * yvals.needtoscale/max(yvals.needtoscale)
yvals[, i] <- yvals.scaled
}
if (orientation == "vertical") {
xrange <- c(1/2, n + 1/2)
yrange <- range(xvals)
}
else {
xrange <- range(xvals)
yrange <- c(min(yvals), max(yvals))
}
plot.new()
plot.window(xlim = xrange, ylim = yrange)
for (i in 1:n) vlnplt(xvals[, i], yvals[, i], center[i],
bordercolor = rainbow(i), bgcolor = rainbow(n - i), orientation = orientation,
col = col[i], ...)
axis(1, at = 1:n, labels = names)
axis(2)
}

a = rnorm(25, 100, 50)
b = rnorm(25, 300, 50)

violin.colors(list("Group A" = a, "Group B" = b), col = 1:2)