You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
175 lines
6.9 KiB
175 lines
6.9 KiB
#' Make waffle (square pie) charts
|
|
#'
|
|
#' Given a named vector, this function will return a ggplot object that
|
|
#' represents a waffle chart of the values. The individual values will be
|
|
#' summed up and each that will be the total number of squares in the grid.
|
|
#' You can perform appropriate value transformation ahead of time to get the
|
|
#' desired waffle layout/effect.
|
|
#'
|
|
#' If the vector is not named or only partially named, capital letters will be
|
|
#' used instead. It is highly suggested that you limit the number of elements
|
|
#' to plot, just like you should if you ever got wasted and decided that a
|
|
#' regular pie chart was a good thing to create and then decide to be totally
|
|
#' evil and make one to pollute this beautiful world of ours.
|
|
#'
|
|
#' Chart title and x-axis labels are optional, especially if you'll just be
|
|
#' exporting to another program for use/display.
|
|
#'
|
|
#' If you specify a string (vs \code{FALSE}) to \code{use_glyph} the function
|
|
#' will map the input to a FontAwesome glyph name and use that glyph for the
|
|
#' tile instead of a block (making it more like an isotype pictogram than a
|
|
#' waffle chart). You'll need to actually install FontAwesome and use
|
|
#' the \code{extrafont} package (\code{https://github.com/wch/extrafont}) to
|
|
#' be able to use the FontAwesome glyphs. Sizing is also up to the user since
|
|
#' fonts do not automatically scale with graphic resize.
|
|
#'
|
|
#' Glyph idea inspired by Ruben C. Arslan (@@_r_c_a)
|
|
#'
|
|
#' @param parts named vector of values to use for the chart
|
|
#' @param rows number of rows of blocks
|
|
#' @param keep keep factor levels (i.e. for consistent legends across waffle plots)
|
|
#' @param xlab text for below the chart. Highly suggested this be used to
|
|
#' give the "1 sq == xyz" relationship if it's not obvious
|
|
#' @param title chart title
|
|
#' @param colors exactly the number of colors as values in \code{parts}.
|
|
#' If omitted, Color Brewer "Set2" colors are used.
|
|
#' @param size width of the separator between blocks (defaults to \code{2})
|
|
#' @param flip flips x & y axes
|
|
#' @param reverse reverses the order of the data
|
|
#' @param equal by default, waffle uses \code{coord_equal}; this can cause
|
|
#' layout problems, so you an use this to disable it if you are using
|
|
#' ggsave or knitr to control output sizes (or manually sizing the chart)
|
|
#' @param pad how many blocks to right-pad the grid with
|
|
#' @param use_glyph use specified FontAwesome glyph
|
|
#' @param glyph_size size of the FontAwesome font
|
|
#' @param legend_pos position of legend
|
|
#' @export
|
|
#' @examples
|
|
#' parts <- c(80, 30, 20, 10)
|
|
#' chart <- waffle(parts, rows=8)
|
|
#' # print(chart)
|
|
#'
|
|
#' # library(extrafont)
|
|
#' # waffle(parts, rows=8, use_glyph="shield")
|
|
#'
|
|
#' parts <- c(One=80, Two=30, Three=20, Four=10)
|
|
#' chart <- waffle(parts, rows=8)
|
|
#' # print(chart)
|
|
waffle <- function(parts, rows=10, keep=TRUE, xlab=NULL, title=NULL, colors=NA,
|
|
size=2, flip=FALSE, reverse=FALSE, equal=TRUE, pad=0,
|
|
use_glyph=FALSE, glyph_size=12, legend_pos="right") {
|
|
|
|
# fill in any missing names
|
|
part_names <- names(parts)
|
|
if (length(part_names) < length(parts)) {
|
|
part_names <- c(part_names, LETTERS[1:length(parts)-length(part_names)])
|
|
}
|
|
|
|
names(parts) <- part_names
|
|
|
|
# use Set2 if no colors are specified
|
|
if (all(is.na(colors))) colors <- suppressWarnings(brewer.pal(length(parts), "Set2"))
|
|
|
|
# make one big vector of all the bits
|
|
parts_vec <- unlist(sapply(1:length(parts), function(i) {
|
|
rep(names(parts)[i], parts[i])
|
|
}))
|
|
|
|
if (reverse) parts_vec <- rev(parts_vec)
|
|
|
|
# setup the data frame for geom_rect
|
|
dat <- expand.grid(y=1:rows, x=seq_len(pad + (ceiling(sum(parts) / rows))))
|
|
|
|
# add NAs if needed to fill in the "rectangle"
|
|
dat$value <- c(parts_vec, rep(NA, nrow(dat)-length(parts_vec)))
|
|
if(!inherits(use_glyph, "logical")){
|
|
fontlab <- rep(fa_unicode[use_glyph],length(unique(parts_vec)))
|
|
dat$fontlab <- c(fontlab[as.numeric(factor(parts_vec))],
|
|
rep(NA, nrow(dat)-length(parts_vec)))
|
|
}
|
|
|
|
dat$value <- ifelse(is.na(dat$value), " ", dat$value)
|
|
|
|
if (" " %in% dat$value) part_names <- c(part_names, " ")
|
|
if (" " %in% dat$value) colors <- c(colors, "#00000000")
|
|
|
|
dat$value <- factor(dat$value, levels=part_names)
|
|
|
|
gg <- ggplot(dat, aes(x=x, y=y))
|
|
|
|
if (flip) gg <- ggplot(dat, aes(x=y, y=x))
|
|
|
|
gg <- gg + theme_bw()
|
|
|
|
# make the plot
|
|
|
|
if (inherits(use_glyph, "logical")) {
|
|
|
|
gg <- gg + geom_tile(aes(fill=value), color="white", size=size)
|
|
gg <- gg + scale_fill_manual(name="",
|
|
values=colors,
|
|
label=part_names,
|
|
na.value="white",
|
|
drop=!keep)
|
|
gg <- gg + guides(fill=guide_legend(override.aes=list(colour="#00000000")))
|
|
gg <- gg + theme(legend.background=element_rect(fill="#00000000", color="#00000000"))
|
|
gg <- gg + theme(legend.key=element_rect(fill="#00000000", color="#00000000"))
|
|
|
|
} else {
|
|
|
|
if (choose_font("FontAwesome", quiet=TRUE) == "") {
|
|
stop("FontAwesome not found. Install via: https://github.com/FortAwesome/Font-Awesome/tree/master/fonts",
|
|
call.=FALSE)
|
|
}
|
|
|
|
suppressWarnings(
|
|
suppressMessages(
|
|
font_import(system.file("fonts", package="waffle"),
|
|
recursive=FALSE,
|
|
prompt=FALSE)))
|
|
|
|
if (!(!interactive() || stats::runif(1) > 0.1)) {
|
|
message("Font Awesome by Dave Gandy - http://fontawesome.io")
|
|
}
|
|
|
|
gg <- gg + geom_tile(color="#00000000", fill="#00000000", size=size, alpha=0, show.legend=FALSE)
|
|
gg <- gg + geom_point(aes(color=value), fill="#00000000", size=0, show.legend=TRUE)
|
|
gg <- gg + geom_text(aes(color=value,label=fontlab),
|
|
family="FontAwesome", size=glyph_size, show.legend=FALSE)
|
|
gg <- gg + scale_color_manual(name="",
|
|
values=colors,
|
|
labels=part_names,
|
|
drop=!keep)
|
|
gg <- gg + guides(color=guide_legend(override.aes=list(shape=15, size=7)))
|
|
gg <- gg + theme(legend.background=element_rect(fill="#00000000", color="#00000000"))
|
|
gg <- gg + theme(legend.key=element_rect(color="#00000000"))
|
|
|
|
}
|
|
|
|
gg <- gg + labs(x=xlab, y=NULL, title=title)
|
|
gg <- gg + scale_x_continuous(expand=c(0, 0))
|
|
gg <- gg + scale_y_continuous(expand=c(0, 0))
|
|
|
|
if (equal) gg <- gg + coord_equal()
|
|
|
|
gg <- gg + theme(panel.grid=element_blank())
|
|
gg <- gg + theme(panel.border=element_blank())
|
|
gg <- gg + theme(panel.background=element_blank())
|
|
gg <- gg + theme(panel.spacing=unit(0, "null"))
|
|
|
|
gg <- gg + theme(axis.text=element_blank())
|
|
gg <- gg + theme(axis.title.x=element_text(size=10))
|
|
gg <- gg + theme(axis.ticks=element_blank())
|
|
gg <- gg + theme(axis.line=element_blank())
|
|
gg <- gg + theme(axis.ticks.length=unit(0, "null"))
|
|
|
|
gg <- gg + theme(plot.title=element_text(size=18))
|
|
|
|
gg <- gg + theme(plot.background=element_blank())
|
|
gg <- gg + theme(panel.spacing=unit(c(0, 0, 0, 0), "null"))
|
|
|
|
gg <- gg + theme(legend.position=legend_pos)
|
|
|
|
gg
|
|
|
|
}
|
|
|