stackedstones.R

## Stacked stones (or ice cream) plot for Kris
##
## 20181019 Benno Pütz
##          puetz@psych.mpg.de

require(RColorBrewer)   # for "nicer" colors

#' Stacked stone plot
#'
#' For a count matrix, order the entries by columns and plot corresponding circles
#' stacked atop each other. The circle areas are propotional to the counts, the largest
#' circle at the bottom.
#'
#' @param data data matix or data.fame
#' @param grid whether to place the cicles on a grid (TRUE) or stack them closely (FALSE)
#' @param ... passed on to other circle plotting function \link{\code{circ}}
#'
#' @return matrix corresponding to the plot (largest value per column in first row)
#' @export
#'
#' @examples
#' stackedstone.plot(ran.d())
stackedstone.plot <- function(data, grid = TRUE, ...){
    n.grps <- nrow(data)
    max.r <-  sqrt(max(data, na.rm = TRUE))
    plot.r <- function(r) sqrt(r)/(2*max.r)
    rows <- max(apply(data, 2, function(x)sum(x>0, na.rm = TRUE)))
    colvec <- if(require(RColorBrewer))
                  comb.brpal(n.grps)
              else
                  colvec <- generate.color.vector(n.grps)

    plot(c(-2, sc <- ncol(data)+2), c(0, rows+1), type = 'n', axes = FALSE, asp = 1,
         xlab = 'groups', ylab = 'ranking')
    box()
    axis(1,
         at = 1:ncol(data),
         labels = if(is.null(colnames(data))) 1:ncol(data) else colnames(data)
         )
    if (grid) axis(2, las = 1)
    res.mat <- matrix(NA, ncol = ncol(data), nrow = rows)
    b.col.idx <- function(pal, i=seq_along(pal)){
        gen <- attr(pal, 'gen')
        if (!is.null(gen) && gen == 'cbp4'){
            seg.len <- length(pal)/4         # only true for comb.brpal palettes made
                                             # of four palette segments

            ((i-1) %/% seg.len + 1) * seg.len
        } else {
            NA
        }
    }
    for(col in 1:ncol(data)){
        offset <- 0
        nz <- sum(data[,col]>0, na.rm = TRUE) #   # of non-zero elements
        o <- order(rank(data[,col]), decreasing = TRUE)[1:nz]
        res.mat[1:nz,col] <- data[o, col]
        for(grp.idx in 1:nz){
            r <- plot.r(data[o[grp.idx], col])
            circ(col,
                 ifelse(grid,
                        grp.idx,
                        offset+r),
                 r = r,
                 col = colvec[o[grp.idx]],
                 border = colvec[b.col.idx(colvec, o[grp.idx])],
                 ...)
            offset <- offset + 2*r
        }
    }

    legend('topleft',
           if(is.null(rownames(data))) paste("grp", 1:n.grps) else rownames(data),
           col = colvec[b.col.idx(colvec)],
           pt.bg = colvec,
           pch = 21,
           ncol = ifelse(n.grps>10, 2, 1),
           bty = ' ')

    sizes <- outer(c(1, 2, 3, 5, 7),10^(0:log10(max.r^2)))
    # may need to drop rows if too many
    ncs <- ncol(sizes)
    use.cols <- 1:ncs
    use.rows <- if(length(sizes)>rows){     # full
        if(length(sizes[1:3,])>rows){       # use 1-2-5
            if(length(sizes[1:2,])>rows){   # use 1-3
                if (ncol(sizes) > rows){    # subset further on 10s?
                    use.cols <- seq(ncs,1, by = -ncs %/% rows)
                }
                1
            } else {
                c(1,3)
            }
        } else {
            c(1,3)
        }
    } else {
        1:5
    }
    all.sizes <- as.vector(sizes[use.rows, use.cols])
    show.sizes <- rev(all.sizes[1:which.max(all.sizes>max(data))])

    for (i in 1:length(sizes)){
        circ(sc, rows+1 - i,
             plot.r(show.sizes[i]),
             col = 'grey',
             border = 'black')
        text(sc-1, rows+1 - i, show.sizes[i])
    }
    return(invisible(res.mat))
}

################################################################################
##   helper functions

#' Generate color vector
#'
#' @param n number of colors
#' @param ... not used
#'
#' @return color vector
#' @export
#'
#' @examples
#' cv <- generate.color.vector(12)
generate.color.vector <- function(n, ...){
    cm <- matrix(rainbow(2*((n+1)%/%2),
                         end = 0.7),
                 ncol=2, byrow = TRUE)
    M <- diag(c(rep(1.3,3),1))
    cm[,2] <- adjustcolor(cm[,2], transform = M)
    attr(cm, 'gen') <- 'gcv'
    return(as.vector(cm))
}


#' Draw base graphics circle with given parameters
#'
#' based on \code{polygon}
#'
#' CAVEAT: when aspect ratio of plot is not equal to 1, the cirrcles will appear as ellipses!
#'
#' @param x \eq{x}-cooordinate of center
#' @param y \eq{y}-cooordinate of center
#' @param r radius
#' @param col fill color
#' @param border border color
#' @param ... other parameters forr \code{polygon}
#' @param n number of edges for approaching circle by polygon
#'
#' @return used for side effect of drawing
#' @export
#'
#' @examples
#' circ(1,1,1)
circ <-  function(x, y, r, col='black', border = NA, ..., n=100){
    phi <- 2*pi * 1:n/n
    xi <- r * cos(phi) + x
    yi <- r * sin(phi) + y
    polygon(xi, yi, col = col, border = border, ...)
}

#' Random data matrix for experimenting
#'
#' @param r number of rows
#' @param c number of columns
#' @param fill fraction of non-zero cells
#'
#' @return data matrix suitable as input for \link{\code{stackedstone.plot}}
#' @export
#'
#' @examples
#' d <- ran.d()
#' stackedstone.plot(d)
#'
#' # for plotting the non-zero entries:
#' d2 <-  d; d2[d==0] <- NA; image(d2)
ran.d <- function(r=20, c=9, fill = 0.3){
    n <- r * c
    d <- ceiling(10 * matrix(rgamma(n, 1), ncol=c))
    nuls <- sample(n, round((1-fill) * n))
    d[nuls] <- 0
    dimnames(d) <- list(LETTERS[1:r],
                        paste0("G", 1:c))
    return(d)
}

##' combine brewer palettes
##'
##' As Rcolorbrewer palettes have no more than 12 elemements (some even less)
##' we combine several palettes get up to 36 colors
##'
##' Thanks to Beibei Jiang for pointing me to this
##'
##' @title Combine RColorBrewer Palettes
##' @param n number of colors in combined palette
##' @return color palette
##' @author Benno Puetz \email{puetz@@psych.mpg.de}
comb.brpal <- function(n){
    elems <- ceiling(n/4)
    brw.pals <- c('Blues', 'Greens', 'Oranges', 'Purples')
    full.pal <- as.vector(sapply(brw.pals, function(i)brewer.pal(elems, i)))
    attr(full.pal, 'gen') <- 'cbp4'   # comb.brpal with 4 segments
    return(full.pal)
}