ggplot2やplotlyを使わないbubble plot

Rではggplot2やplotlyを使うと簡単にbubble plotを描画できますが、標準のplotを使ってもそんなに手間暇でもないです。より楽ができて、見栄えのするggplot2かplotlyの利用をお勧めしますが。

1. データセット

以下のデータセットをプロットすることを考えましょう。bubble plotを使う用途では滅多に無いと思いますが、負の数も入れておきます。

set.seed(26)
n <- 30
x <- runif(n)
y <- runif(n)
z <- seq(-1, 1, length.out=n)

2. プロット関数の引数を計算する関数

plotにつけるパラメーターcexとbgに渡すベクトルを計算する関数を用意します。JavaScript風のクラスになっている気がしますが、気にしないでください。

pch_properties <- function(z, zlim = c(min(abs(z)), max(abs(z))), 
    colors = c(rgb(1.0, 0, 0, 0.5), rgb(0, 0, 1.0, 0.5)), 
    cex.min = 1, cex.max = 10){

    A <-  sqrt(zlim[2])/cex.max

    list(
        getCex = function(...){
            a <- list(...)
            if(0 < length(a) && is.numeric(a[[1]])) z <- unlist(a) 
            browser(expr = !is.numeric(z))
            r <- numeric(length(z))
            r[z!=0] <- sqrt(abs(z[z!=0]))/A
            r[r<cex.min] <- cex.min
            r
        },
        getBg = function(...){
            a <- list(...)
            if(0 < length(a) && is.numeric(a[[1]])) z <- unlist(a) 
            colors[1 + (z>=0)*1]
        }
    )
}

3. 凡例のパラメーターを調整する関数

凡例のパラメーターを調整して、凡例を表示する関数を用意します。

writeLegendtoRight <- function(...){
    # 凡例のパラメーターに凡例非表示を追加する
    params <- c(0, 0, list(...))
    params[["xpd"]] <- TRUE
    params[["plot"]] <- FALSE
    params[["xjust"]] <- 0

    # legendのサイズ計算の補正用の値
    line <- 1
    if(is.numeric(params[["line"]])){
        line <- params[["line"]]
        params[["line"]] <- NULL
    }

    # 描画領域のサイズを計算
    r_legend <- do.call(legend, params)

    # 表示位置を計算（描画エリア外にセット/xpd=TRUE）
    usr <- par()$usr
    params[[1]] <- usr[2] + line*strheight("h")
    params[[2]] <- usr[4]

    # 非表示オプションを消す
    params[["plot"]] <- NULL

    # 描画する
    do.call(legend, params)
}

4. プロット

準備が済んだのでプロットしましょう。

# 変数zからプロットのパラメーターを計算
pp <- pch_properties(z)

# 描画領域外に凡例を描くので、右側の余白を大きくとる
par(mar = c(4, 4, 1, 10))

# プロットを行なう
plot(x, y, pch = 21, cex = pp$getCex(), bg = pp$getBg())

# 凡例に使うzの値
i <- c(-1, -0.5, -0.25)
i <- c(i, 0, -1*rev(i))

# 凡例を描く
writeLegendtoRight(0, 0, 
    legend = sapply(i, function(i){
        substitute(z==a, list(a = round(i, 2)))
    }),
    x.intersp = max(pp$getCex(i))/2 - 2,
    y.intersp = max(pp$getCex(i))/2 - 1,
    adj = c(0, 0.5), 
    pch = 21,
    col = "black",
    pt.cex = pp$getCex(i),
    pt.bg = pp$getBg(i), 
    bty = "n",
# 表示位置調整 
    line = 2)