geom/stat

DESCRIPTION

@@ -36,4 +36,4 @@ Imports:
     curl,
     stringr,
     stats
-RoxygenNote: 6.0.1.9000
+RoxygenNote: 6.1.1

NAMESPACE

@@ -1,8 +1,13 @@
 # Generated by roxygen2: do not edit by hand
 
+export(GeomWaffle)
+export(StatWaffle)
 export(fa_grep)
 export(fa_list)
+export(geom_waffle)
 export(iron)
+export(stat_waffle)
+export(theme_enhance_waffle)
 export(waffle)
 import(curl)
 import(gridExtra)

R/geom-waffle.R

@@ -0,0 +1,123 @@
+#' Waffle (Square pie chart) Geom
+#'
+#' There are two special/critical `aes()` mappings:
+#' - `fill` (so the geom knows which column to map the country names/abbrevs to)
+#' - `values` (which column you're mapping the filling for the squares with)
+#'
+#' @md
+#' @param mapping Set of aesthetic mappings created by `aes()` or
+#'   `aes_()`. If specified and `inherit.aes = TRUE` (the
+#'   default), it is combined with the default mapping at the top level of the
+#'   plot. You must supply `mapping` if there is no plot mapping.
+#' @param n_rows how many rows should there be in the waffle chart? default is 10
+#' @param make_proportional compute proportions from the raw values? (i.e. each
+#'        value `n` will be replaced with `n`/`sum(n)`); default is `FALSE`.
+#' @param data The data to be displayed in this layer. There are three
+#'    options:
+#'
+#'    If `NULL`, the default, the data is inherited from the plot
+#'    data as specified in the call to `ggplot()`.
+#'
+#'    A `data.frame`, or other object, will override the plot
+#'    data. All objects will be fortified to produce a data frame. See
+#'    `fortify()` for which variables will be created.
+#'
+#'    A `function` will be called with a single argument,
+#'    the plot data. The return value must be a `data.frame.`, and
+#'    will be used as the layer data.
+#' @param na.rm If `FALSE`, the default, missing values are removed with
+#'   a warning. If `TRUE`, missing values are silently removed.
+#' @param show.legend logical. Should this layer be included in the legends?
+#'   `NA`, the default, includes if any aesthetics are mapped.
+#'   `FALSE` never includes, and `TRUE` always includes.
+#'   It can also be a named logical vector to finely select the aesthetics to
+#'   display.
+#' @param inherit.aes If `FALSE`, overrides the default aesthetics,
+#'   rather than combining with them. This is most useful for helper functions
+#'   that define both data and aesthetics and shouldn't inherit behaviour from
+#'   the default plot specification, e.g. `borders()`.
+#' @param ... other arguments passed on to `layer()`. These are
+#'   often aesthetics, used to set an aesthetic to a fixed value, like
+#'   `color = "red"` or `size = 3`. They may also be parameters
+#'   to the paired geom/stat.
+#' @export
+geom_waffle <- function(
+  mapping = NULL, data = NULL,
+  n_rows = 10, make_proportional = FALSE,
+  na.rm = TRUE, show.legend = NA, inherit.aes = TRUE, ...) {
+
+  ggplot2::layer(
+    data = data,
+    mapping = mapping,
+    stat = "waffle",
+    geom = GeomWaffle,
+    position = "identity",
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list(
+      na.rm = TRUE,
+      n_rows = n_rows,
+      make_proportional = make_proportional,
+      ...
+    )
+  )
+
+}
+
+#' @rdname geom_waffle
+#' @export
+GeomWaffle <- ggplot2::ggproto(
+  `_class` = "GeomWaffle",
+  `_inherit` = ggplot2::Geom,
+
+  default_aes = ggplot2::aes(
+    values = "values",
+    fill = NA, colour = "#b2b2b2", alpha = NA,
+    size = 0.125, linetype = 1, width = NA, height = NA
+  ),
+
+  required_aes = c("x", "y"),
+
+  extra_params = c("na.rm", "width", "height"),
+
+  setup_data = function(data, params) {
+
+    # message("Called GEOM setup_data()")
+
+    waf.dat <- data #data.frame(data)#, stringsAsFactors=FALSE)
+
+    waf.dat$width <- waf.dat$width %||% params$width %||% ggplot2::resolution(waf.dat$x, FALSE)
+    waf.dat$height <- waf.dat$height %||% params$height %||% ggplot2::resolution(waf.dat$y, FALSE)
+
+    transform(
+      waf.dat,
+      xmin = x - width / 2,  xmax = x + width / 2,  width = NULL,
+      ymin = y - height / 2, ymax = y + height / 2, height = NULL
+    ) -> xdat
+
+    xdat
+
+  },
+
+  draw_group = function(self, data, panel_params, coord,
+                        n_rows = 10, make_proportional = FALSE) {
+
+    # message("Called GEOM draw_group()")
+
+    tile_data <- data
+    # tile_data$size <- border_size
+    # tile_data$colour <- border_col
+
+    coord <- ggplot2::coord_equal()
+
+    grid::gList(
+      GeomTile$draw_panel(tile_data, panel_params, coord)
+    ) -> grobs
+
+    ggname("geom_waffle", grid::grobTree(children = grobs))
+
+  },
+
+  draw_key = ggplot2::draw_key_polygon
+
+)

R/stat-waffle.R

@@ -0,0 +1,91 @@
+#' @rdname geom_waffle
+#' @export
+stat_waffle<- function(mapping = NULL, data = NULL,
+                       n_rows = 10, make_proportional = FALSE,
+                       na.rm = NA, show.legend = NA,
+                       inherit.aes = TRUE, ...) {
+
+  layer(
+    stat = StatWtg,
+    data = data,
+    mapping = mapping,
+    geom = "waffle",
+    position = "identity",
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list(
+      na.rm = na.rm,
+      n_rows = n_rows,
+      make_proportional = make_proportional,
+      ...
+    )
+  )
+}
+
+#' @rdname geom_waffle
+#' @export
+StatWaffle <- ggplot2::ggproto(
+  `_class` = "StatWaffle",
+  `_inherit` = ggplot2::Stat,
+
+  required_aes = c("fill", "values"),
+
+  compute_layer = function(self, data, params, panels) {
+
+    if (inherits(data[["fill"]], "factor")) {
+      flvls <- levels(data[["fill"]])
+    } else {
+      flvls <- levels(factor(data[["fill"]]))
+    }
+
+    p <- split(data, data$PANEL)
+
+    lapply(p, function(.x) {
+
+      parts_vec <- unlist(sapply(1:length(.x[["fill"]]), function(i) {
+        rep(as.character(.x[["fill"]][i]), .x[["values"]][i])
+      }))
+
+      pgrp_vec <- unlist(sapply(1:length(.x[["fill"]]), function(i) {
+        rep(.x$group, .x[["values"]][i])
+      }))
+
+      expand.grid(
+        y = 1:params$n_rows,
+        x = seq_len((ceiling(sum(.x[["values"]]) / params$n_rows)))#,
+        # stringsAsFactors = FALSE
+      ) -> tdf
+
+      parts_vec <- c(parts_vec, rep(NA, nrow(tdf)-length(parts_vec)))
+
+      # tdf$parts <- parts_vec
+      tdf[["values"]] <- NA
+      tdf[["fill"]] <- parts_vec
+      tdf[["PANEL"]] <- .x[["PANEL"]][1]
+      tdf[["group"]] <- 1:nrow(tdf)
+
+      tdf <- tdf[sapply(tdf[["fill"]], function(x) !is.na(x)),]
+
+    }) -> p
+
+    p <- plyr::rbind.fill(p)
+    p[["fill"]] <- factor(p[["fill"]], levels=flvls)
+
+    # print(str(p))
+
+    p
+
+  },
+
+  compute_panel = function(self, data, scales, na.rm = FALSE,
+                           n_rows = 10, make_proportional = FALSE) {
+
+    # message("Called STAT compute_panel()")
+
+    ggproto_parent(Stat, self)$compute_panel(data, scales,
+                                             n_rows = 10,
+                                             make_proportional = FALSE)
+
+  }
+
+)

R/utils.r

@@ -75,3 +75,16 @@ insert_unit <- function (x, values, after = length(x)) {
   }
 
 }
+
+# Name ggplot grid object
+# Convenience function to name grid objects
+#
+# @keyword internal
+ggname <- function(prefix, grob) {
+  grob$name <- grid::grobName(grob, prefix)
+  grob
+}
+
+"%||%" <- function(a, b) { if (!is.null(a)) a else b }
+
+.pt <- 2.84527559055118

R/waffle-enhance.R

@@ -0,0 +1,28 @@
+#' Waffle chart theme cruft remover that can be used with any other theme
+#'
+#' Removes:
+#'
+#' - panel grid
+#' - all axis text
+#' - all axis ticks
+#' - all axis titles
+#'
+#' @md
+#' @export
+theme_enhance_waffle<- function() {
+
+  ret <- theme(panel.grid = element_blank())
+  ret <- ret + theme(axis.text = element_blank())
+  ret <- ret + theme(axis.text.x = element_blank())
+  ret <- ret + theme(axis.text.y = element_blank())
+  ret <- ret + theme(axis.title = element_blank())
+  ret <- ret + theme(axis.title.x = element_blank())
+  ret <- ret + theme(axis.title.x.top = element_blank())
+  ret <- ret + theme(axis.title.x.bottom = element_blank())
+  ret <- ret + theme(axis.title.y = element_blank())
+  ret <- ret + theme(axis.title.y.left = element_blank())
+  ret <- ret + theme(axis.title.y.right = element_blank())
+
+  ret
+
+}

README.Rmd

@@ -24,6 +24,7 @@ The following functions are implemented:
 - `iron` : vertically stitch together multiple waffle plots, left-aligning edges (best if used with the `waffle` `pad` parameter)
 - `fa_grep`:	Search FontAwesome names for a pattern
 - `fa_list`:	List all FontAwesome names
+- `geom_waffle`/`stat_waffle`: Waffle geoms! (WIP)
 
 ## Installation
 
@@ -44,6 +45,33 @@ library(waffle)
 packageVersion("waffle")
 ```
 
+### Geoms! (WIP)
+
+```{r geoms, fig.width=6, fig.height=8, fig.retina=2}
+library(hrbrthemes)
+library(waffle)
+library(tidyverse)
+
+tibble(
+  parts = factor(rep(month.abb[1:3], 3), levels=month.abb[1:3]),
+  values = c(10, 20, 30, 6, 14, 40, 30, 20, 10),
+  fct = c(rep("Thing 1", 3), rep("Thing 2", 3), rep("Thing 3", 3))
+) -> xdf
+
+ggplot(xdf, aes(fill=parts, values=values)) +
+  geom_waffle(color = "white", size=1.125, n_rows = 6) +
+  facet_wrap(~fct, ncol=1) +
+  scale_x_discrete(expand=c(0,0)) +
+  scale_y_discrete(expand=c(0,0)) +
+  ggthemes::scale_fill_tableau(name=NULL) +
+  coord_equal() +
+  labs(
+    title = "Faceted Waffle Geoms"
+  ) +
+  theme_ipsum_rc(grid="") +
+  theme_enhance_waffle()
+```
+
 ### Basic example
 
 ```{r fig0, fig.width=6, fig.height=2.5}

README.md

@@ -28,13 +28,13 @@ The following functions are implemented:
   - `iron` : vertically stitch together multiple waffle plots,
     left-aligning edges (best if used with the `waffle` `pad` parameter)
   - `fa_grep`: Search FontAwesome names for a pattern
-  - \`fa\_list: List all FontAwesome names
+  - `fa_list`: List all FontAwesome names
+  - `geom_waffle`/`stat_waffle`: Waffle geoms\! (WIP)
 
 ## Installation
 
 ``` r
-install.packages("devtools")
-install_github("hrbrmstr/waffle")
+install.packages("waffle")
 ```
 
 ## Usage
@@ -44,9 +44,38 @@ library(waffle)
 
 # current verison
 packageVersion("waffle")
-## [1] '0.9.0'
+## [1] '0.9.1'
 ```
 
+### Geoms\! (WIP)
+
+``` r
+library(hrbrthemes)
+library(waffle)
+library(tidyverse)
+
+tibble(
+  parts = factor(rep(month.abb[1:3], 3), levels=month.abb[1:3]),
+  values = c(10, 20, 30, 6, 14, 40, 30, 20, 10),
+  fct = c(rep("Thing 1", 3), rep("Thing 2", 3), rep("Thing 3", 3))
+) -> xdf
+
+ggplot(xdf, aes(fill=parts, values=values)) +
+  geom_waffle(color = "white", size=1.125, n_rows = 6) +
+  facet_wrap(~fct, ncol=1) +
+  scale_x_discrete(expand=c(0,0)) +
+  scale_y_discrete(expand=c(0,0)) +
+  ggthemes::scale_fill_tableau(name=NULL) +
+  coord_equal() +
+  labs(
+    title = "Faceted Waffle Geoms"
+  ) +
+  theme_ipsum_rc(grid="") +
+  theme_enhance_waffle()
+```
+
+<img src="README_files/figure-gfm/geoms-1.png" width="576" />
+
 ### Basic example
 
 ``` r

man/geom_waffle.Rd

@@ -0,0 +1,75 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/geom-waffle.R, R/stat-waffle.R
+\docType{data}
+\name{geom_waffle}
+\alias{geom_waffle}
+\alias{GeomWaffle}
+\alias{stat_waffle}
+\alias{StatWaffle}
+\title{Waffle (Square pie chart) Geom}
+\format{An object of class \code{GeomWaffle} (inherits from \code{Geom}, \code{ggproto}, \code{gg}) of length 7.}
+\usage{
+geom_waffle(mapping = NULL, data = NULL, n_rows = 10,
+  make_proportional = FALSE, na.rm = TRUE, show.legend = NA,
+  inherit.aes = TRUE, ...)
+
+GeomWaffle
+
+stat_waffle(mapping = NULL, data = NULL, n_rows = 10,
+  make_proportional = FALSE, na.rm = NA, show.legend = NA,
+  inherit.aes = TRUE, ...)
+
+StatWaffle
+}
+\arguments{
+\item{mapping}{Set of aesthetic mappings created by \code{aes()} or
+\code{aes_()}. If specified and \code{inherit.aes = TRUE} (the
+default), it is combined with the default mapping at the top level of the
+plot. You must supply \code{mapping} if there is no plot mapping.}
+
+\item{data}{The data to be displayed in this layer. There are three
+options:
+
+If \code{NULL}, the default, the data is inherited from the plot
+data as specified in the call to \code{ggplot()}.
+
+A \code{data.frame}, or other object, will override the plot
+data. All objects will be fortified to produce a data frame. See
+\code{fortify()} for which variables will be created.
+
+A \code{function} will be called with a single argument,
+the plot data. The return value must be a \code{data.frame.}, and
+will be used as the layer data.}
+
+\item{n_rows}{how many rows should there be in the waffle chart? default is 10}
+
+\item{make_proportional}{compute proportions from the raw values? (i.e. each
+value \code{n} will be replaced with \code{n}/\code{sum(n)}); default is \code{FALSE}.}
+
+\item{na.rm}{If \code{FALSE}, the default, missing values are removed with
+a warning. If \code{TRUE}, missing values are silently removed.}
+
+\item{show.legend}{logical. Should this layer be included in the legends?
+\code{NA}, the default, includes if any aesthetics are mapped.
+\code{FALSE} never includes, and \code{TRUE} always includes.
+It can also be a named logical vector to finely select the aesthetics to
+display.}
+
+\item{inherit.aes}{If \code{FALSE}, overrides the default aesthetics,
+rather than combining with them. This is most useful for helper functions
+that define both data and aesthetics and shouldn't inherit behaviour from
+the default plot specification, e.g. \code{borders()}.}
+
+\item{...}{other arguments passed on to \code{layer()}. These are
+often aesthetics, used to set an aesthetic to a fixed value, like
+\code{color = "red"} or \code{size = 3}. They may also be parameters
+to the paired geom/stat.}
+}
+\description{
+There are two special/critical \code{aes()} mappings:
+\itemize{
+\item \code{fill} (so the geom knows which column to map the country names/abbrevs to)
+\item \code{values} (which column you're mapping the filling for the squares with)
+}
+}
+\keyword{datasets}

man/theme_enhance_waffle.Rd

@@ -0,0 +1,19 @@
+% Generated by roxygen2: do not edit by hand
+% Please edit documentation in R/waffle-enhance.R
+\name{theme_enhance_waffle}
+\alias{theme_enhance_waffle}
+\title{Waffle chart theme cruft remover that can be used with any other theme}
+\usage{
+theme_enhance_waffle()
+}
+\description{
+Removes:
+}
+\details{
+\itemize{
+\item panel grid
+\item all axis text
+\item all axis ticks
+\item all axis titles
+}
+}

man/waffle.Rd

@@ -5,8 +5,8 @@
 \title{Make waffle (square pie) charts}
 \usage{
 waffle(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,
+  colors = NA, size = 2, flip = FALSE, reverse = FALSE,
+  equal = TRUE, pad = 0, use_glyph = FALSE, glyph_size = 12,
   glyph_font = "FontAwesome", glyph_font_family = "FontAwesome",
   legend_pos = "right")
 }