myballoonplot.r

myballoonplot.default <- function (x, y, z, xlab, ylab, zlab = deparse(substitute(z)),
    dotsize = 2/max(strwidth(19), strheight(19)), dotchar = 19,
    col.bar.x = "lightgray", col.bar.y = "lightgray",
    dotcolor = "skyblue", text.size = 1, text.color = par("fg"),
    main, label = TRUE, label.digits = 2, label.size = 1, label.color = par("fg"),
    scale.method = c("volume", "diameter"), scale.range = c("absolute",
        "relative"), colsrt = par("srt"), rowsrt = par("srt"),
    colmar = 1, rowmar = 2, show.zeros = FALSE, show.margins = TRUE,
    cum.margins = TRUE, sorted = TRUE, label.lines = TRUE, fun = function(x) sum(x,
        na.rm = T), hide.duplicates = TRUE, ...)
{
    if (is.null(names(x))) {
        xnames <- as.character(substitute(x))
        if (length(xnames) > 1)
            xnames <- xnames[-1]
    }
    else xnames <- names(x)
    if (is.null(names(y))) {
        ynames <- as.character(substitute(y))
        if (length(ynames) > 1)
            ynames <- ynames[-1]
    }
    else ynames <- names(y)
    scale.method <- match.arg(scale.method)
    scale.range <- match.arg(scale.range)
    if (scale.method == "absolute" && any(z < 0, na.rm = TRUE))
        warning("z value(s) below zero detected.", " No balloons will be displayed for these cells.")
    if (missing(main)) {
        if (scale.method == "volume")
            main <- paste("Balloon Plot for ", paste(xnames,
                collapse = ", "), " by ", paste(ynames, collapse = ", "),
                ".\nArea is proportional to ", zlab, ".", sep = "")
        else main <- paste("Balloon Plot for ", paste(ynames,
            collapse = ", "), " by ", paste(ynames, collapse = ", "),
            ".\nDiameter is proportional to ", zlab, ".", sep = "")
    }
    if (length(dotcolor) < length(z))
        dotcolor <- rep(dotcolor, length = length(z))
    if (is.list(x)) {
        xlabs <- x
        x$sep = ":"
        x <- do.call(paste, x)
    }
    else xlabs <- list(x)
    if (is.list(y)) {
        ylabs <- y
        y$sep = ":"
        y <- do.call(paste, y)
        ylab <- paste(names(y))
    }
    else ylabs <- list(y)
    if (sorted) {
        ord.x <- do.call(order, xlabs)
        ord.y <- do.call(order, ylabs)
    }
    else ord.x <- ord.y <- 1:length(x)
    forceOrder <- function(X, sord, lord) factor(X[sord], levels = unique(X[lord]))
    x <- forceOrder(x, ord.y, ord.y)
    y <- forceOrder(y, ord.y, ord.y)
    z <- as.numeric(z[ord.y])
    dotcolor <- dotcolor[ord.y]
    xlabs <- unique(data.frame(lapply(xlabs, forceOrder, sord = ord.y,
        lord = ord.y)))
    ylabs <- unique(data.frame(lapply(ylabs, forceOrder, sord = ord.y,
        lord = ord.y)))
    myscale <- function(X, min = 0, max = 16, scale.method, scale.range) {
        if (scale.method == "volume") {
            X[X < 0] <- 0
            X <- sqrt(X)
        }
        if (scale.range == "relative")
            X <- (X - min(X, na.rm = TRUE))
        X <- X/max(X, na.rm = TRUE)
        X <- min + X * (max - min)
        cin.x <- par("cin")[1]
        cin.y <- par("cin")[2]
        if (cin.x < cin.y)
            X <- X * cin.x/cin.y
        X
    }
    nlabels.y <- length(ylabs)
    nlabels.x <- length(xlabs)
    tab1 <- split(data.frame(z, dotcolor, x, y), f = list(x,
        y))
    ztab <- do.call(rbind, lapply(tab1, FUN = function(X) cbind(z = fun(X[,
        1]), X[1, -1])))
    oldpar <- par("xpd", "mar")
    on.exit(par(oldpar))
    if (!show.margins) {
        xlim = c(-0.5, nlevels(x) + nlabels.y * rowmar - 0.25)
        ylim = c(0.5, nlevels(y) + nlabels.x * colmar + 1)
    }
    else {
        xlim = c(-0.5, nlevels(x) + nlabels.y * rowmar + 1)
        ylim = c(0, nlevels(y) + nlabels.x * colmar + 1)
    }
    plot(x = nlabels.y * rowmar + 0.25 + as.numeric(ztab$x) -
        1, y = nlevels(y) - as.numeric(ztab$y) + 1, cex = myscale(ztab$z,
        max = dotsize, scale.method = scale.method, scale.range = scale.range),
        pch = dotchar, col = as.character(ztab$dotcolor), xlab = "",
        ylab = "", xaxt = "n", yaxt = "n", bty = "n", xaxs = "i",
        yaxs = "i", xlim = xlim, ylim = ylim, ...)
    ny <- nlevels(ztab$y)
    nx <- nlevels(ztab$x)
    sumz <- sum(ztab$z, na.rm = TRUE)
    colsumz <- sapply(split(ztab$z, ztab$y), sum, na.rm = TRUE)
    rowsumz <- sapply(split(ztab$z, ztab$x), sum, na.rm = TRUE)
    if (show.margins) {
        text(x = (1:nx) + nlabels.y * rowmar + 0.25 - 1, y = 0.25,
            labels = format(c(sumz, rowsumz), digits = label.digits)[-1],
            font = 1, adj = c(0.5, 0), col = text.color, cex = text.size)
        rowlabs <- format(c(sumz, colsumz), digits = label.digits)[-1]
        width <- max(strwidth(rowlabs), na.rm = TRUE)
        text(x = nx + nlabels.y * rowmar - 0.25 + width, y = (ny:1),
            labels = rowlabs, font = 1, adj = c(1, 0.5), col = text.color,
            cex = text.size)
        text(x = nx + nlabels.y * rowmar - 0.25 + width, y = 0.25,
            labels = sumz, font = 1, adj = c(1, 0), col = text.color,
            cex = text.size)
    }
    if (cum.margins) {
        cx <- c(0, cumsum(rowsumz)/sumz)
        rect(xleft = nlabels.y * rowmar - 1 - 0.25 + 1:nx, xright = nlabels.y *
            rowmar - 1 + 0.75 + 1:nx, ybottom = ny + 0.75 + cx[1:nx] *
            colmar * nlabels.x, ytop = ny + 0.75 + cx[2:(nx +
            1)] * colmar * nlabels.x, col = col.bar.y, border = NA)
        cy <- c(0, cumsum(colsumz)/sumz)
        rect(xleft = -0.5 + rowmar * cy[ny:1] * nlabels.y, xright = -0.5 +
            rowmar * cy[(ny + 1):2] * nlabels.y, ybottom = 1:ny -
            0.5, ytop = 1:ny + 0.5, col = rev(col.bar.x), border = NA)
        tx <- paste(levels(x), "\n[", rowsumz, "]")
        ty <- paste(levels(y), "\n[", colsumz, "]")
    }
    segments(x0 = nlabels.y * rowmar - 0.25, x1 = nx + nlabels.y *
        rowmar - 0.25, y0 = (0:ny) + 0.5, y1 = (0:ny) + 0.5)
    segments(x0 = (0:nx) + nlabels.y * rowmar - 0.25, x1 = (0:nx) +
        nlabels.y * rowmar - 0.25, y0 = 0.5, y1 = ny + 0.5, )
    if (hide.duplicates)
        undupe <- function(X) {
            X <- as.character(X)
            c(X[1], ifelse(X[-1] == X[-length(X)], "", X[-1]))
        }
    else undupe <- function(X) X
    for (i in 1:nlabels.x) {
        y <- ny + 0.75 + (nlabels.x - i + 0.5) * colmar
        text(x = (1:nx) + nlabels.y * rowmar + 0.25 - 1, y = y,
            labels = undupe(xlabs[, i]), srt = colsrt, font = 1,
            col = text.color, cex = text.size)
    }
    for (i in 1:length(ylabs)) {
        text(y = ny:1, x = (i - 0.5) * rowmar - 0.5, labels = undupe(ylabs[,
            i]), srt = rowsrt, font = 1, col = text.color, cex = text.size)
    }
    if (missing(ylab) || length(ylab) == 0)
        text(x = ((1:length(ylabs)) - 0.5) * rowmar - 0.5, y = ny +
            0.5, labels = ynames, srt = colsrt, font = 2, adj = c(0.5,
            0), col = text.color, cex = text.size)
    else text(x = ((1:length(ylab)) - 0.5) * rowmar - 0.5, y = ny +
        0.5, labels = ylab, srt = colsrt, font = 2, adj = c(0.5,
        0), col = text.color, cex = text.size)
    if (missing(xlab) || length(xlab) == 0)
        text(x = nlabels.y * rowmar - 0.25 - strwidth(","), y = ny +
            0.75 + ((nlabels.x:1) - 1 + 0.5) * colmar, labels = xnames,
            srt = colsrt, font = 2, adj = c(1, 0.5), col = text.color,
            cex = text.size)
    else text(x = nlabels.y * rowmar - 0.25 - strwidth(","),
        y = ny + 0.75 + ((length(xlab):1) - 1 + 0.5) * colmar,
        labels = xlab, srt = colsrt, font = 2, adj = c(1, 0.5),
        col = text.color, cex = text.size)
    if (label.lines) {
        segments(x0 = (0:nlabels.y) * rowmar - 0.5, x1 = (0:nlabels.y) *
            rowmar - 0.5, y0 = 0.5, y1 = ny + 0.5)
        segments(x0 = nlabels.y * rowmar - 0.25, x1 = nlabels.y *
            rowmar + nx - 0.25, y0 = (0:nlabels.x) * colmar +
            ny + 0.75, y1 = (0:nlabels.x) * colmar + ny + 0.75)
    }
    if (label) {
        if (show.zeros)
            indiv <- 1:length(ztab$y)
        else indiv <- which(ztab$z != 0)
        text(x = as.numeric(ztab$x[indiv]) + nlabels.y * rowmar -
            0.75, y = ny - as.numeric(ztab$y[indiv]) + 1, labels = format(ztab$z[indiv],
            digits = label.digits), font = 2, adj = c(0.5, 0.5),
            col = label.color, cex = label.size)
    }
    title(main = main)
}


myballoonplot.table <- function (x, xlab, ylab, zlab, show.zeros = FALSE, show.margins = TRUE,
    ...)
{
    obj <- x
    tmp <- as.data.frame(x)
    x <- tmp[, 1]
    y <- tmp[, 2]
    z <- tmp[, 3]
    tableflag <- TRUE
    if (missing(xlab))
        xlab <- names(dimnames(obj))[1]
    if (missing(ylab))
        ylab <- names(dimnames(obj))[2]
    if (missing(zlab))
        zlab <- "Freq"
    myballoonplot.default(x, y, z, xlab = xlab, ylab = ylab, zlab = zlab,
        show.zeros = show.zeros, show.margins = show.margins,
        ...)
}