legolda: Color Topic Models of the Lego Dat Set

#' Make waffle (square pie) charts
#'
#' Given a named vector or a data frame, 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 a data frame is used, the first two columns should contain the desired names
#' and the values, respectively.
#'
#' 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 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 or a data frame 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)
#' waffle(parts, rows=8)
#'
#' parts <- data.frame(
#'   names = LETTERS[1:4],
#'   vals = c(80, 30, 20, 10)
#' )
#'
#' waffle(parts, rows=8)
#'
#' # 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)
waffle2 <- 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",
                    grout_color = "white") {
  if (inherits(parts, "data.frame")) {
    setNames(
      unlist(parts[, 2], use.names = FALSE),
      unlist(parts[, 1], use.names = FALSE)
    ) -> parts
  }

  # 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")) {
    fa_unicode <- fa_unicode()
    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 = grout_color, 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
}


# Wrapper for the waffle plot
 
#' A wrapper of the waffle function
#'
#'
#' @param data A tibble with columns, name,theme, year, and counts. 
#'    The counts column is a column of tables.
#' @param row An integer. The number of rows of the waffle plot
#' @param size A double. Controls the border size of individual squares.
#' @param nchr An integer. The number of characters in the title.
#' @param bgcol A valid 
#' @return return The plot
#' @export
waff <- function(data, nchr, bgcol, rows, size = 0.2) {
 
  title  <- paste0( stringr::str_sub(data$name, 1, nchr),
              ", ", data$theme, " theme",
              ", (", data$year, ")")

  pal <- names(data$counts[[1]])
  counts <- data$counts[[1]]

  wp <- waffle2(counts, 
          title = title, 
          colors = pal,  
          rows = rows, 
          size = 0.3, 
          grout_color = bgcol) 
   wp + theme_waff(bgcol)
}