boB Rudis
5 years ago
20 changed files with 1482 additions and 743 deletions
@ -0,0 +1,66 @@ |
|||
geom_rrect <- function(mapping = NULL, data = NULL, # nocov start |
|||
stat = "identity", position = "identity", |
|||
radius = grid::unit(6, "pt"), |
|||
..., |
|||
na.rm = FALSE, |
|||
show.legend = NA, |
|||
inherit.aes = TRUE) { |
|||
layer( |
|||
data = data, |
|||
mapping = mapping, |
|||
stat = stat, |
|||
geom = GeomRrect, |
|||
position = position, |
|||
show.legend = show.legend, |
|||
inherit.aes = inherit.aes, |
|||
params = list( |
|||
radius = radius, |
|||
na.rm = na.rm, |
|||
... |
|||
) |
|||
) |
|||
} |
|||
|
|||
GeomRrect <- ggplot2::ggproto( |
|||
"GeomRrect", ggplot2::Geom, |
|||
|
|||
default_aes = ggplot2::aes( |
|||
fill = "grey35", size = 0.5, linetype = 1, alpha = NA#, colour = NA |
|||
), |
|||
|
|||
required_aes = c("xmin", "xmax", "ymin", "ymax"), |
|||
|
|||
draw_panel = function(self, data, panel_params, coord, |
|||
radius = grid::unit(6, "pt")) { |
|||
|
|||
coords <- coord$transform(data, panel_params) |
|||
|
|||
lapply(1:length(coords$xmin), function(i) { |
|||
|
|||
grid::roundrectGrob( |
|||
coords$xmin[i], coords$ymax[i], |
|||
width = (coords$xmax[i] - coords$xmin[i]), |
|||
height = (coords$ymax[i] - coords$ymin)[i], |
|||
r = radius, |
|||
default.units = "native", |
|||
just = c("left", "top"), |
|||
gp = grid::gpar( |
|||
col = coords$colour[i], |
|||
fill = alpha(coords$fill[i], coords$alpha[i]), |
|||
lwd = coords$size[i] * .pt, |
|||
lty = coords$linetype[i], |
|||
lineend = "butt" |
|||
) |
|||
) |
|||
|
|||
}) -> gl |
|||
|
|||
grobs <- do.call(grid::gList, gl) |
|||
|
|||
ggname("geom_rrect", grid::grobTree(children = grobs)) |
|||
|
|||
}, |
|||
|
|||
draw_key = ggplot2::draw_key_polygon |
|||
|
|||
) # nocov end |
@ -1 +1,9 @@ |
|||
utils::globalVariables(c("x", "y", "value")) |
|||
|
|||
.dbg <- TRUE |
|||
|
|||
msg <- function(...) { |
|||
|
|||
if (.dbg) message(...) |
|||
|
|||
} |
@ -1,233 +1,234 @@ |
|||
#' @export |
|||
draw_key_pictogram <- function(data, params, size) { |
|||
|
|||
# message("Called draw_key_pictogram()") |
|||
|
|||
# print(str(data, 1)) |
|||
# print(str(params, 1)) |
|||
# print(str(size, 1)) |
|||
|
|||
# return(draw_key_text(data, params, size)) |
|||
|
|||
data[["label"]] <- .fa_unicode[.fa_unicode[["name"]] %in% data[["fa_glyph"]], "unicode"] |
|||
fat <- .fa_unicode[.fa_unicode[["name"]] %in% data[["fa_glyph"]], "type"] |
|||
ftrans <- c(solid = "FontAwesome5Free-Solid", brands = "FontAwesome5Brands-Regular") |
|||
data[["family"]] <- ftrans[fat] |
|||
data[["size"]] <- data[["size"]] * 2 |
|||
|
|||
grid::textGrob( |
|||
data$label, 0.5, 0.25, |
|||
rot = data$angle %||% 0, |
|||
gp = grid::gpar( |
|||
col = alpha(data$colour %||% data$fill %||% "black", data$alpha), |
|||
fontfamily = data$family %||% "", |
|||
fontface = data$fontface %||% 1, |
|||
fontsize = (data$size %||% 3.88) * .pt |
|||
) |
|||
) |
|||
} |
|||
#' Isotype pictogram "waffle" charts |
|||
#' |
|||
#' There are two special/critical `aes()` mappings: |
|||
#' - `colour` (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 flip If `TRUE`, flip x and y coords. n_rows then becomes n_cols. |
|||
#' Useful to achieve waffle column chart effect. Defaults is `FALSE`. |
|||
#' @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 |
|||
#' @examples |
|||
#' data.frame( |
|||
#' 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_pictogram() + |
|||
#' facet_wrap(~fct) + |
|||
#' coord_equal() |
|||
geom_pictogram <- function( |
|||
mapping = NULL, data = NULL, |
|||
n_rows = 10, flip = FALSE, make_proportional = FALSE, |
|||
na.rm = TRUE, show.legend = NA, inherit.aes = TRUE, ...) { |
|||
|
|||
# message("Called geom_pictogram()") |
|||
|
|||
ggplot2::layer( |
|||
data = data, |
|||
mapping = mapping, |
|||
stat = "pictogram", |
|||
geom = GeomPictogram, |
|||
position = "identity", |
|||
show.legend = show.legend, |
|||
inherit.aes = inherit.aes, |
|||
check.aes = FALSE, |
|||
params = list( |
|||
na.rm = na.rm, |
|||
n_rows = n_rows, |
|||
flip = flip, |
|||
make_proportional = make_proportional, |
|||
use = "colour", |
|||
... |
|||
) |
|||
) |
|||
|
|||
} |
|||
|
|||
#' @rdname geom_pictogram |
|||
#' @export |
|||
GeomPictogram <- ggplot2::ggproto( |
|||
`_class` = "GeomPictogram", |
|||
`_inherit` = ggplot2::Geom, |
|||
|
|||
default_aes = ggplot2::aes( |
|||
fa_glyph = "circle", fa_type = "solid", |
|||
fill = NA, colour = "#b2b2b2", alpha = NA, |
|||
size = 2, linetype = 1, width = NA, height = NA |
|||
), |
|||
|
|||
required_aes = c("x", "y", "values", "fa_glyph", "fa_type"), |
|||
|
|||
extra_params = c("na.rm", "width", "height", "flip", "use"), |
|||
|
|||
setup_data = function(data, params) { |
|||
|
|||
# message("Called GeomPictogram::setup_data()") |
|||
# print(str(data, 1)) |
|||
|
|||
waf.dat <- data |
|||
|
|||
# swap x and y values if flip is TRUE |
|||
if (params$flip) { |
|||
waf.dat$x_temp <- waf.dat$x |
|||
waf.dat$x <- waf.dat$y |
|||
waf.dat$y <- waf.dat$x_temp |
|||
waf.dat$x_temp <- NULL |
|||
} |
|||
|
|||
# reduce all values by 0.5 |
|||
# this allows for axis ticks to align _between_ square rows/cols |
|||
# rather than in the middle of a row/col |
|||
waf.dat$x <- waf.dat$x - 0.5 |
|||
waf.dat$y <- waf.dat$y - 0.5 |
|||
|
|||
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 |
|||
|
|||
# print(str(xdat, 1)) |
|||
|
|||
xdat |
|||
|
|||
}, |
|||
|
|||
draw_group = function(self, data, panel_params, coord, |
|||
n_rows = 10, make_proportional = FALSE) { |
|||
|
|||
# message("Called GeomPictogram::draw_group()") |
|||
|
|||
# message("Called GEOM draw_group()") |
|||
|
|||
tile_data <- data |
|||
# tile_data$size <- border_size |
|||
# tile_data$colour <- border_col |
|||
|
|||
coord <- ggplot2::coord_equal() |
|||
|
|||
# gg <- gg + geom_tile( |
|||
# color = "#00000000", fill = "#00000000", size = size, |
|||
# alpha = 0, show.legend = FALSE |
|||
# ) |
|||
|
|||
gtdat <- tile_data |
|||
gtdat[["colour"]] <- "#00000000" |
|||
gtdat[["color"]] <- "#00000000" |
|||
gtdat[["fill"]] <- "#00000000" |
|||
|
|||
g_pgdat <<- tile_data |
|||
|
|||
self$default_aes[["fa_glyph"]] <- tile_data[["fa_glyph"]][[1]] |
|||
|
|||
pgdat <- tile_data |
|||
pgdat[["label"]] <- .fa_unicode[.fa_unicode[["name"]] %in% pgdat[["fa_glyph"]], "unicode"] |
|||
fat <- .fa_unicode[.fa_unicode[["name"]] %in% pgdat[["fa_glyph"]], "type"] |
|||
ftrans <- c(solid = "FontAwesome5Free-Solid", brands = "FontAwesome5Brands-Regular") |
|||
pgdat[["family"]] <- ftrans[fat] |
|||
pgdat[["size"]] <- pgdat[["size"]] * 2 |
|||
pgdat[["angle"]] = 0 |
|||
pgdat[["hjust"]] <- 0.5 |
|||
pgdat[["vjust"]] <- 0.5 |
|||
pgdat[["fontface"]] <- 1 |
|||
pgdat[["lineheight"]] <- 1 |
|||
|
|||
# print(str(pgdat, 1)) |
|||
|
|||
# gg <- gg + geom_text( |
|||
# aes(color = value, label = fontlab), |
|||
# family = glyph_font_family, |
|||
# size = glyph_size, |
|||
# show.legend = FALSE |
|||
# ) |
|||
|
|||
grid::gList( |
|||
# GeomTile$draw_panel(gtdat, panel_params, coord), |
|||
GeomText$draw_panel(pgdat, panel_params, coord) |
|||
) -> grobs |
|||
|
|||
ggname("geom_pictogram", grid::grobTree(children = grobs)) |
|||
|
|||
}, |
|||
|
|||
aesthetics = function(self) { |
|||
# message("Called GeomPictogram::aesthetics()") |
|||
c(union(self$required_aes, names(self$default_aes)), self$optional_aes, "group") |
|||
}, |
|||
|
|||
draw_key = draw_key_pictogram |
|||
|
|||
) |
|||
# #' @export |
|||
# draw_key_pictogram <- function(data, params, size) { |
|||
# |
|||
# # message("Called draw_key_pictogram()") |
|||
# |
|||
# # print(str(data, 1)) |
|||
# # print(str(params, 1)) |
|||
# # print(str(size, 1)) |
|||
# |
|||
# # return(draw_key_text(data, params, size)) |
|||
# |
|||
# data[["label"]] <- .fa_unicode[.fa_unicode[["name"]] %in% data[["fa_glyph"]], "unicode"] |
|||
# fat <- .fa_unicode[.fa_unicode[["name"]] %in% data[["fa_glyph"]], "type"] |
|||
# ftrans <- c(solid = "FontAwesome5Free-Solid", brands = "FontAwesome5Brands-Regular") |
|||
# data[["family"]] <- ftrans[fat] |
|||
# data[["size"]] <- data[["size"]] * 2 |
|||
# |
|||
# grid::textGrob( |
|||
# data$label, 0.5, 0.25, |
|||
# rot = data$angle %||% 0, |
|||
# gp = grid::gpar( |
|||
# col = alpha(data$colour %||% data$fill %||% "black", data$alpha), |
|||
# fontfamily = data$family %||% "", |
|||
# fontface = data$fontface %||% 1, |
|||
# fontsize = (data$size %||% 3.88) * .pt |
|||
# ) |
|||
# ) |
|||
# } |
|||
# #' Isotype pictogram "waffle" charts |
|||
# #' |
|||
# #' There are two special/critical `aes()` mappings: |
|||
# #' - `colour` (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 flip If `TRUE`, flip x and y coords. n_rows then becomes n_cols. |
|||
# #' Useful to achieve waffle column chart effect. Defaults is `FALSE`. |
|||
# #' @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 |
|||
# #' @examples |
|||
# #' data.frame( |
|||
# #' 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_pictogram() + |
|||
# #' facet_wrap(~fct) + |
|||
# #' coord_equal() |
|||
# geom_pictogram <- function( |
|||
# mapping = NULL, data = NULL, |
|||
# n_rows = 10, flip = FALSE, make_proportional = FALSE, |
|||
# na.rm = TRUE, show.legend = NA, inherit.aes = TRUE, ...) { |
|||
# |
|||
# # message("Called geom_pictogram()") |
|||
# |
|||
# ggplot2::layer( |
|||
# data = data, |
|||
# mapping = mapping, |
|||
# stat = "pictogram", |
|||
# geom = GeomPictogram, |
|||
# position = "identity", |
|||
# show.legend = show.legend, |
|||
# inherit.aes = inherit.aes, |
|||
# check.aes = FALSE, |
|||
# params = list( |
|||
# na.rm = na.rm, |
|||
# n_rows = n_rows, |
|||
# flip = flip, |
|||
# make_proportional = make_proportional, |
|||
# use = "colour", |
|||
# ... |
|||
# ) |
|||
# ) |
|||
# |
|||
# } |
|||
# |
|||
# #' @rdname geom_pictogram |
|||
# #' @export |
|||
# GeomPictogram <- ggplot2::ggproto( |
|||
# `_class` = "GeomPictogram", |
|||
# `_inherit` = ggplot2::Geom, |
|||
# |
|||
# default_aes = ggplot2::aes( |
|||
# fa_glyph = "circle", fa_type = "solid", |
|||
# fill = NA, colour = "#b2b2b2", alpha = NA, |
|||
# size = 2, linetype = 1, width = NA, height = NA |
|||
# ), |
|||
# |
|||
# required_aes = c("x", "y", "values", "fa_glyph", "fa_type"), |
|||
# |
|||
# extra_params = c("na.rm", "width", "height", "flip", "use"), |
|||
# |
|||
# setup_data = function(data, params) { |
|||
# |
|||
# # message("Called GeomPictogram::setup_data()") |
|||
# # print(str(data, 1)) |
|||
# |
|||
# waf.dat <- data |
|||
# |
|||
# # swap x and y values if flip is TRUE |
|||
# if (params$flip) { |
|||
# waf.dat$x_temp <- waf.dat$x |
|||
# waf.dat$x <- waf.dat$y |
|||
# waf.dat$y <- waf.dat$x_temp |
|||
# waf.dat$x_temp <- NULL |
|||
# } |
|||
# |
|||
# # reduce all values by 0.5 |
|||
# # this allows for axis ticks to align _between_ square rows/cols |
|||
# # rather than in the middle of a row/col |
|||
# waf.dat$x <- waf.dat$x - 0.5 |
|||
# waf.dat$y <- waf.dat$y - 0.5 |
|||
# |
|||
# 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 |
|||
# |
|||
# # print(str(xdat, 1)) |
|||
# |
|||
# xdat |
|||
# |
|||
# }, |
|||
# |
|||
# draw_group = function(self, data, panel_params, coord, |
|||
# n_rows = 10, make_proportional = FALSE) { |
|||
# |
|||
# # message("Called GeomPictogram::draw_group()") |
|||
# |
|||
# # message("Called GEOM draw_group()") |
|||
# |
|||
# tile_data <- data |
|||
# # tile_data$size <- border_size |
|||
# # tile_data$colour <- border_col |
|||
# |
|||
# coord <- ggplot2::coord_equal() |
|||
# |
|||
# # gg <- gg + geom_tile( |
|||
# # color = "#00000000", fill = "#00000000", size = size, |
|||
# # alpha = 0, show.legend = FALSE |
|||
# # ) |
|||
# |
|||
# gtdat <- tile_data |
|||
# gtdat[["colour"]] <- "#00000000" |
|||
# gtdat[["color"]] <- "#00000000" |
|||
# gtdat[["fill"]] <- "#00000000" |
|||
# |
|||
# g_pgdat <<- tile_data |
|||
# |
|||
# self$default_aes[["fa_glyph"]] <- tile_data[["fa_glyph"]][[1]] |
|||
# |
|||
# pgdat <- tile_data |
|||
# pgdat[["label"]] <- .fa_unicode[.fa_unicode[["name"]] %in% pgdat[["fa_glyph"]], "unicode"] |
|||
# fat <- .fa_unicode[.fa_unicode[["name"]] %in% pgdat[["fa_glyph"]], "type"] |
|||
# ftrans <- c(solid = "FontAwesome5Free-Solid", brands = "FontAwesome5Brands-Regular") |
|||
# pgdat[["family"]] <- ftrans[fat] |
|||
# pgdat[["size"]] <- pgdat[["size"]] * 2 |
|||
# pgdat[["angle"]] = 0 |
|||
# pgdat[["hjust"]] <- 0.5 |
|||
# pgdat[["vjust"]] <- 0.5 |
|||
# pgdat[["fontface"]] <- 1 |
|||
# pgdat[["lineheight"]] <- 1 |
|||
# |
|||
# # print(str(pgdat, 1)) |
|||
# |
|||
# # gg <- gg + geom_text( |
|||
# # aes(color = value, label = fontlab), |
|||
# # family = glyph_font_family, |
|||
# # size = glyph_size, |
|||
# # show.legend = FALSE |
|||
# # ) |
|||
# |
|||
# grid::gList( |
|||
# # GeomTile$draw_panel(gtdat, panel_params, coord), |
|||
# GeomText$draw_panel(pgdat, panel_params, coord) |
|||
# ) -> grobs |
|||
# |
|||
# ggname("geom_pictogram", grid::grobTree(children = grobs)) |
|||
# |
|||
# }, |
|||
# |
|||
# aesthetics = function(self) { |
|||
# # message("Called GeomPictogram::aesthetics()") |
|||
# c(union(self$required_aes, names(self$default_aes)), self$optional_aes, "group") |
|||
# }, |
|||
# |
|||
# draw_key = draw_key_pictogram |
|||
# |
|||
# ) |
|||
# |
@ -0,0 +1,46 @@ |
|||
geom_rtile <- function(mapping = NULL, data = NULL, |
|||
stat = "identity", position = "identity", |
|||
radius = grid::unit(6, "pt"), |
|||
..., |
|||
na.rm = FALSE, |
|||
show.legend = NA, |
|||
inherit.aes = TRUE) { |
|||
ggplot2::layer( |
|||
data = data, |
|||
mapping = mapping, |
|||
stat = stat, |
|||
geom = GeomRtile, |
|||
position = position, |
|||
show.legend = show.legend, |
|||
inherit.aes = inherit.aes, |
|||
params = list( |
|||
radius = radius, |
|||
na.rm = na.rm, |
|||
... |
|||
) |
|||
) |
|||
} |
|||
|
|||
GeomRtile <- ggplot2::ggproto("GeomRtile", GeomRrect, |
|||
|
|||
extra_params = c("na.rm", "width", "height"), |
|||
|
|||
setup_data = function(data, params) { |
|||
data$width <- data$width %||% params$width %||% ggplot2::resolution(data$x, FALSE) |
|||
data$height <- data$height %||% params$height %||% ggplot2::resolution(data$y, FALSE) |
|||
|
|||
transform(data, |
|||
xmin = x - width / 2, xmax = x + width / 2, width = NULL, |
|||
ymin = y - height / 2, ymax = y + height / 2, height = NULL |
|||
) |
|||
}, |
|||
|
|||
default_aes = ggplot2::aes( |
|||
fill = "grey20", colour = NA, size = 0.1, linetype = 1, alpha = NA |
|||
), |
|||
|
|||
required_aes = c("x", "y"), |
|||
|
|||
draw_key = ggplot2::draw_key_polygon |
|||
|
|||
) |
@ -1,152 +1,154 @@ |
|||
#' 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 flip If `TRUE`, flip x and y coords. n_rows then becomes n_cols. |
|||
#' Useful to achieve waffle column chart effect. Defaults is `FALSE`. |
|||
#' @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 |
|||
#' @examples |
|||
#' data.frame( |
|||
#' 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() + |
|||
#' facet_wrap(~fct) + |
|||
#' coord_equal() |
|||
geom_waffle <- function( |
|||
mapping = NULL, data = NULL, |
|||
n_rows = 10, flip = FALSE, make_proportional = FALSE, |
|||
na.rm = TRUE, show.legend = NA, inherit.aes = TRUE, ...) { |
|||
# #' 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 flip If `TRUE`, flip x and y coords. n_rows then becomes n_cols. |
|||
# #' Useful to achieve waffle column chart effect. Defaults is `FALSE`. |
|||
# #' @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 |
|||
# #' @examples |
|||
# #' data.frame( |
|||
# #' 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() + |
|||
# #' facet_wrap(~fct) + |
|||
# #' coord_equal() |
|||
# geom_waffle <- function( |
|||
# mapping = NULL, data = NULL, |
|||
# n_rows = 10, flip = FALSE, 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, |
|||
# flip = flip, |
|||
# make_proportional = make_proportional, |
|||
# use = "fill", |
|||
# ... |
|||
# ) |
|||
# ) |
|||
# |
|||
# } |
|||
# |
|||
# #' @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", "flip", "use"), |
|||
# |
|||
# setup_data = function(data, params) { |
|||
# |
|||
# # message("Called GEOM setup_data()") |
|||
# |
|||
# waf.dat <- data #data.frame(data)#, stringsAsFactors=FALSE) |
|||
# |
|||
# # swap x and y values if flip is TRUE |
|||
# if (params$flip) { |
|||
# waf.dat$x_temp <- waf.dat$x |
|||
# waf.dat$x <- waf.dat$y |
|||
# waf.dat$y <- waf.dat$x_temp |
|||
# waf.dat$x_temp <- NULL |
|||
# } |
|||
# |
|||
# # reduce all values by 0.5 |
|||
# # this allows for axis ticks to align _between_ square rows/cols |
|||
# # rather than in the middle of a row/col |
|||
# waf.dat$x <- waf.dat$x - .5 |
|||
# waf.dat$y <- waf.dat$y - .5 |
|||
# |
|||
# 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 |
|||
# |
|||
# ) |
|||
|
|||
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, |
|||
flip = flip, |
|||
make_proportional = make_proportional, |
|||
use = "fill", |
|||
... |
|||
) |
|||
) |
|||
|
|||
} |
|||
|
|||
#' @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", "flip", "use"), |
|||
|
|||
setup_data = function(data, params) { |
|||
|
|||
# message("Called GEOM setup_data()") |
|||
|
|||
waf.dat <- data #data.frame(data)#, stringsAsFactors=FALSE) |
|||
|
|||
# swap x and y values if flip is TRUE |
|||
if (params$flip) { |
|||
waf.dat$x_temp <- waf.dat$x |
|||
waf.dat$x <- waf.dat$y |
|||
waf.dat$y <- waf.dat$x_temp |
|||
waf.dat$x_temp <- NULL |
|||
} |
|||
|
|||
# reduce all values by 0.5 |
|||
# this allows for axis ticks to align _between_ square rows/cols |
|||
# rather than in the middle of a row/col |
|||
waf.dat$x <- waf.dat$x - .5 |
|||
waf.dat$y <- waf.dat$y - .5 |
|||
|
|||
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 |
|||
|
|||
) |
@ -1,142 +1,143 @@ |
|||
#' @rdname geom_pictogram |
|||
#' @export |
|||
stat_pictogram <- function(mapping = NULL, data = NULL, |
|||
n_rows = 10, make_proportional = FALSE, |
|||
na.rm = NA, show.legend = NA, |
|||
inherit.aes = TRUE, ...) { |
|||
|
|||
layer( |
|||
stat = StatPictogram, |
|||
data = data, |
|||
mapping = mapping, |
|||
geom = "pictogram", |
|||
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_pictogram |
|||
#' @export |
|||
StatPictogram <- ggplot2::ggproto( |
|||
`_class` = "StatPictogram", |
|||
`_inherit` = ggplot2::Stat, |
|||
|
|||
required_aes = c("colour", "values", "fa_type", "fa_glyph"), |
|||
extra_params = c("na.rm", "width", "height", "flip", "use"), |
|||
|
|||
setup_params = function(data, params) { |
|||
# message("Called StatPictogram::setup_params()") |
|||
params |
|||
}, |
|||
|
|||
setup_data = function(data, params) { |
|||
# message("Called StatPictogram::setup_data()") |
|||
# print(str(data, 1)) |
|||
data |
|||
}, |
|||
|
|||
compute_layer = function(self, data, params, panels) { |
|||
|
|||
# message("Called StatPictogram::compute_layer()") |
|||
# print(str(data, 1)) |
|||
|
|||
use <- params[["use"]] |
|||
|
|||
if (inherits(data[[use]], "factor")) { |
|||
flvls <- levels(data[[use]]) |
|||
} else { |
|||
flvls <- levels(factor(data[[use]])) |
|||
} |
|||
|
|||
tr1 <- data[c(use, "fa_glyph", "fa_type")] |
|||
tr1 <- tr1[!duplicated(tr1), ] |
|||
|
|||
gtrans <- tr1[, "fa_glyph"] |
|||
names(gtrans) <- tr1[, use] |
|||
|
|||
ttrans <- tr1[, "fa_type"] |
|||
names(ttrans) <- tr1[, use] |
|||
|
|||
# print(str(tr1, 1)) |
|||
|
|||
p <- split(data, data$PANEL) |
|||
|
|||
lapply(p, function(.x) { |
|||
|
|||
parts_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
rep(as.character(.x[[use]][i]), .x[["values"]][i]) |
|||
})) |
|||
|
|||
pgrp_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
rep(.x$group, .x[[use]][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"]] <- parts_vec |
|||
tdf[[use]] <- parts_vec |
|||
|
|||
tdf[["fa_glyph"]] <- gtrans[tdf[[use]]] |
|||
tdf[["fa_type"]] <- ttrans[tdf[[use]]] |
|||
|
|||
tdf[["PANEL"]] <- .x[["PANEL"]][1] |
|||
tdf[["group"]] <- 1:nrow(tdf) |
|||
|
|||
tdf <- tdf[sapply(tdf[[use]], function(x) !is.na(x)),] |
|||
|
|||
tdf |
|||
|
|||
}) -> p |
|||
|
|||
p <- plyr::rbind.fill(p) |
|||
p[[use]] <- factor(p[[use]], levels=flvls) |
|||
|
|||
# print(str(p, 1)) |
|||
|
|||
p |
|||
|
|||
}, |
|||
|
|||
finish_layer = function(self, data, params) { |
|||
# message("Called StatPictogram::finish_layer()") |
|||
self$default_aes[["fa_glyph"]] <- "square" |
|||
# print(str(data,1)) |
|||
# print(str(params, 1)) |
|||
data |
|||
}, |
|||
|
|||
compute_panel = function(self, data, scales, na.rm = FALSE, |
|||
n_rows = 10, make_proportional = FALSE) { |
|||
|
|||
# message("Called StatPictogram::compute_panel()") |
|||
|
|||
ggproto_parent(Stat, self)$compute_panel( |
|||
data, scales, |
|||
n_rows = n_rows, |
|||
make_proportional = make_proportional, |
|||
na.rm = na.rm |
|||
) |
|||
|
|||
}, |
|||
|
|||
aesthetics = function(self) { |
|||
# message("Called StatPictogram::aesthetics()") |
|||
c(union(self$required_aes, names(self$default_aes)), "group") |
|||
} |
|||
|
|||
|
|||
) |
|||
# #' @rdname geom_pictogram |
|||
# #' @export |
|||
# stat_pictogram <- function(mapping = NULL, data = NULL, |
|||
# n_rows = 10, make_proportional = FALSE, |
|||
# na.rm = NA, show.legend = NA, |
|||
# inherit.aes = TRUE, ...) { |
|||
# |
|||
# layer( |
|||
# stat = StatPictogram, |
|||
# data = data, |
|||
# mapping = mapping, |
|||
# geom = "pictogram", |
|||
# 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_pictogram |
|||
# #' @export |
|||
# StatPictogram <- ggplot2::ggproto( |
|||
# `_class` = "StatPictogram", |
|||
# `_inherit` = ggplot2::Stat, |
|||
# |
|||
# required_aes = c("colour", "values", "fa_type", "fa_glyph"), |
|||
# extra_params = c("na.rm", "width", "height", "flip", "use"), |
|||
# |
|||
# setup_params = function(data, params) { |
|||
# # message("Called StatPictogram::setup_params()") |
|||
# params |
|||
# }, |
|||
# |
|||
# setup_data = function(data, params) { |
|||
# # message("Called StatPictogram::setup_data()") |
|||
# # print(str(data, 1)) |
|||
# data |
|||
# }, |
|||
# |
|||
# compute_layer = function(self, data, params, panels) { |
|||
# |
|||
# # message("Called StatPictogram::compute_layer()") |
|||
# # print(str(data, 1)) |
|||
# |
|||
# use <- params[["use"]] |
|||
# |
|||
# if (inherits(data[[use]], "factor")) { |
|||
# flvls <- levels(data[[use]]) |
|||
# } else { |
|||
# flvls <- levels(factor(data[[use]])) |
|||
# } |
|||
# |
|||
# tr1 <- data[c(use, "fa_glyph", "fa_type")] |
|||
# tr1 <- tr1[!duplicated(tr1), ] |
|||
# |
|||
# gtrans <- tr1[, "fa_glyph"] |
|||
# names(gtrans) <- tr1[, use] |
|||
# |
|||
# ttrans <- tr1[, "fa_type"] |
|||
# names(ttrans) <- tr1[, use] |
|||
# |
|||
# # print(str(tr1, 1)) |
|||
# |
|||
# p <- split(data, data$PANEL) |
|||
# |
|||
# lapply(p, function(.x) { |
|||
# |
|||
# parts_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
# rep(as.character(.x[[use]][i]), .x[["values"]][i]) |
|||
# })) |
|||
# |
|||
# pgrp_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
# rep(.x$group, .x[[use]][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"]] <- parts_vec |
|||
# tdf[[use]] <- parts_vec |
|||
# |
|||
# tdf[["fa_glyph"]] <- gtrans[tdf[[use]]] |
|||
# tdf[["fa_type"]] <- ttrans[tdf[[use]]] |
|||
# |
|||
# tdf[["PANEL"]] <- .x[["PANEL"]][1] |
|||
# tdf[["group"]] <- 1:nrow(tdf) |
|||
# |
|||
# tdf <- tdf[sapply(tdf[[use]], function(x) !is.na(x)),] |
|||
# |
|||
# tdf |
|||
# |
|||
# }) -> p |
|||
# |
|||
# p <- plyr::rbind.fill(p) |
|||
# p[[use]] <- factor(p[[use]], levels=flvls) |
|||
# |
|||
# # print(str(p, 1)) |
|||
# |
|||
# p |
|||
# |
|||
# }, |
|||
# |
|||
# finish_layer = function(self, data, params) { |
|||
# # message("Called StatPictogram::finish_layer()") |
|||
# self$default_aes[["fa_glyph"]] <- "square" |
|||
# # print(str(data,1)) |
|||
# # print(str(params, 1)) |
|||
# data |
|||
# }, |
|||
# |
|||
# compute_panel = function(self, data, scales, na.rm = FALSE, |
|||
# n_rows = 10, make_proportional = FALSE) { |
|||
# |
|||
# # message("Called StatPictogram::compute_panel()") |
|||
# |
|||
# ggproto_parent(Stat, self)$compute_panel( |
|||
# data, scales, |
|||
# n_rows = n_rows, |
|||
# make_proportional = make_proportional, |
|||
# na.rm = na.rm |
|||
# ) |
|||
# |
|||
# }, |
|||
# |
|||
# aesthetics = function(self) { |
|||
# # message("Called StatPictogram::aesthetics()") |
|||
# c(union(self$required_aes, names(self$default_aes)), "group") |
|||
# } |
|||
# |
|||
# |
|||
# ) |
|||
# |
@ -1,97 +1,98 @@ |
|||
#' @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 = StatWaffle, |
|||
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"), |
|||
|
|||
extra_params = c("na.rm", "width", "height", "flip", "use"), |
|||
|
|||
compute_layer = function(self, data, params, panels) { |
|||
|
|||
use <- params[["use"]] |
|||
|
|||
if (inherits(data[[use]], "factor")) { |
|||
flvls <- levels(data[[use]]) |
|||
} else { |
|||
flvls <- levels(factor(data[[use]])) |
|||
} |
|||
|
|||
p <- split(data, data$PANEL) |
|||
|
|||
lapply(p, function(.x) { |
|||
|
|||
parts_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
rep(as.character(.x[[use]][i]), .x[["values"]][i]) |
|||
})) |
|||
|
|||
pgrp_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
rep(.x$group, .x[[use]][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[[use]] <- parts_vec |
|||
tdf[["PANEL"]] <- .x[["PANEL"]][1] |
|||
tdf[["group"]] <- 1:nrow(tdf) |
|||
|
|||
tdf <- tdf[sapply(tdf[[use]], function(x) !is.na(x)),] |
|||
|
|||
}) -> p |
|||
|
|||
p <- plyr::rbind.fill(p) |
|||
p[[use]] <- factor(p[[use]], 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 |
|||
) |
|||
|
|||
} |
|||
|
|||
) |
|||
# #' @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 = StatWaffle, |
|||
# 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"), |
|||
# |
|||
# extra_params = c("na.rm", "width", "height", "flip", "use"), |
|||
# |
|||
# compute_layer = function(self, data, params, panels) { |
|||
# |
|||
# use <- params[["use"]] |
|||
# |
|||
# if (inherits(data[[use]], "factor")) { |
|||
# flvls <- levels(data[[use]]) |
|||
# } else { |
|||
# flvls <- levels(factor(data[[use]])) |
|||
# } |
|||
# |
|||
# p <- split(data, data$PANEL) |
|||
# |
|||
# lapply(p, function(.x) { |
|||
# |
|||
# parts_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
# rep(as.character(.x[[use]][i]), .x[["values"]][i]) |
|||
# })) |
|||
# |
|||
# pgrp_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
# rep(.x$group, .x[[use]][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[[use]] <- parts_vec |
|||
# tdf[["PANEL"]] <- .x[["PANEL"]][1] |
|||
# tdf[["group"]] <- 1:nrow(tdf) |
|||
# |
|||
# tdf <- tdf[sapply(tdf[[use]], function(x) !is.na(x)),] |
|||
# |
|||
# }) -> p |
|||
# |
|||
# p <- plyr::rbind.fill(p) |
|||
# p[[use]] <- factor(p[[use]], 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 |
|||
# ) |
|||
# |
|||
# } |
|||
# |
|||
# ) |
|||
# |
@ -0,0 +1,355 @@ |
|||
draw_key_waffle <- function(data, params, size, ...) { # nocov start |
|||
|
|||
# msg("Called => draw_key_waffle()") |
|||
# |
|||
# print(str(data, 1)) |
|||
# print(str(params, 1)) |
|||
# print(str(size, 1)) |
|||
# print(str(list(...), 1)) |
|||
|
|||
grid::roundrectGrob( |
|||
r = min(params$radius, unit(3, "pt")), |
|||
default.units = "native", |
|||
width = 0.9, height = 0.9, |
|||
name = "lkey", |
|||
gp = grid::gpar( |
|||
col = params[["color"]][[1]] %l0% params[["colour"]][1] %l0% data[["colour"]][[1]] %l0% "#00000000", |
|||
fill = alpha(data$fill %||% data$colour %||% "grey20", data$alpha), |
|||
lty = data$linetype %||% 1 |
|||
) |
|||
) |
|||
} # nocov end |
|||
|
|||
#' 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 flip If `TRUE`, flip x and y coords. n_rows then becomes n_cols. |
|||
#' Useful to achieve waffle column chart effect. Defaults is `FALSE`. |
|||
#' @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 radius radius |
|||
#' @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 |
|||
#' @examples |
|||
#' data.frame( |
|||
#' parts = factor(rep(month.abb[1:3], 3), levels=month.abb[1:3]), |
|||
#' vals = 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 = vals)) + |
|||
#' geom_waffle() + |
|||
#' facet_wrap(~fct) |
|||
geom_waffle <- function(mapping = NULL, data = NULL, |
|||
n_rows = 10, make_proportional = FALSE, |
|||
na.rm = NA, show.legend = NA, flip = FALSE, |
|||
radius = grid::unit(0, "npc"), |
|||
inherit.aes = TRUE, ...) { |
|||
|
|||
# msg("Called => geom_waffle::geom_waffle()") |
|||
# msg("Done With => geom_waffle::geom_waffle()") |
|||
|
|||
layer( |
|||
stat = StatWaffle, |
|||
data = data, |
|||
mapping = mapping, |
|||
geom = GeomWaffle, |
|||
position = "identity", |
|||
show.legend = show.legend, |
|||
inherit.aes = inherit.aes, |
|||
check.param = FALSE, |
|||
params = list( |
|||
na.rm = na.rm, |
|||
n_rows = n_rows, |
|||
make_proportional = make_proportional, |
|||
flip = flip, |
|||
radius = radius, |
|||
... |
|||
) |
|||
) |
|||
} |
|||
|
|||
#' @rdname geom_waffle |
|||
#' @export |
|||
GeomWaffle <- ggplot2::ggproto( |
|||
`_class` = "GeomWaffle", |
|||
`_inherit` = GeomRtile, |
|||
|
|||
default_aes = ggplot2::aes( |
|||
fill = NA, alpha = NA, colour = NA, |
|||
size = 0.125, linetype = 1, width = NA, height = NA |
|||
), |
|||
|
|||
draw_group = function(self, data, panel_params, coord, |
|||
n_rows = 10, make_proportional = FALSE, flip = FALSE, |
|||
radius = grid::unit(0, "npc")) { |
|||
|
|||
# msg("Called => GeomWaffle::draw_group()") |
|||
|
|||
coord <- ggplot2::coord_equal() |
|||
grobs <- GeomRtile$draw_panel(data, panel_params, coord, radius) |
|||
|
|||
# msg("Done With => GeomWaffle::draw_group()") |
|||
|
|||
ggname("geom_waffle", grid::grobTree(children = grobs)) |
|||
|
|||
}, |
|||
|
|||
|
|||
draw_panel = function(self, data, panel_params, coord, |
|||
n_rows = 10, make_proportional = FALSE, flip = FALSE, |
|||
radius = grid::unit(0, "npc")) { |
|||
|
|||
# msg("Called => GeomWaffle::draw_panel()") |
|||
|
|||
coord <- ggplot2::coord_equal() |
|||
|
|||
# grid::gList( |
|||
grobs <- GeomRtile$draw_panel(data, panel_params, coord, radius) |
|||
# ) -> grobs |
|||
|
|||
# msg("Done With => GeomWaffle::draw_panel()") |
|||
|
|||
ggname("geom_waffle", grid::grobTree(children = grobs)) |
|||
|
|||
}, |
|||
|
|||
draw_key = draw_key_waffle |
|||
|
|||
) |
|||
|
|||
#' @rdname geom_waffle |
|||
#' @export |
|||
stat_waffle <- function(mapping = NULL, data = NULL, geom = "blank", |
|||
n_rows = 10, make_proportional = FALSE, flip = FALSE, |
|||
radius = grid::unit(0, "npc"), |
|||
na.rm = NA, show.legend = NA, |
|||
inherit.aes = TRUE, ...) { |
|||
|
|||
# msg("Called => stat_waffle::stat_waffle()") |
|||
# msg("Done With => stat_waffle::stat_waffle()") |
|||
|
|||
layer( |
|||
stat = StatWaffle, |
|||
data = data, |
|||
mapping = mapping, |
|||
geom = geom, |
|||
position = "identity", |
|||
show.legend = show.legend, |
|||
inherit.aes = inherit.aes, |
|||
check.param = FALSE, |
|||
params = list( |
|||
na.rm = na.rm, |
|||
n_rows = n_rows, |
|||
make_proportional = make_proportional, |
|||
flip = flip, |
|||
radius = radius, |
|||
... |
|||
) |
|||
) |
|||
} |
|||
|
|||
#' @rdname geom_waffle |
|||
#' @export |
|||
StatWaffle <- ggplot2::ggproto( |
|||
|
|||
`_class` = "StatWaffle", |
|||
`_inherit` = ggplot2::Stat, |
|||
|
|||
extra_params = c("na.rm", "n_rows", "make_proportional", "flip", "radius"), |
|||
|
|||
required_aes = c("fill", "values", "colour"), |
|||
|
|||
setup_params = function(data, params) { |
|||
# msg("Called => StatWaffle::setup_params()") |
|||
# msg("Done With => StatWaffle::setup_params()") |
|||
params |
|||
}, |
|||
|
|||
setup_data = function(data, params) { |
|||
|
|||
# msg("Called => StatWaffle::setup_data()") |
|||
# |
|||
# print(str(data, 1)) |
|||
# print(str(params, 1)) |
|||
|
|||
use <- "fill" |
|||
|
|||
if (inherits(data[[use]], "factor")) { |
|||
flvls <- levels(data[[use]]) |
|||
} else { |
|||
flvls <- levels(factor(data[[use]])) |
|||
} |
|||
|
|||
if (inherits(data[["colour"]], "factor")) { |
|||
clvls <- levels(data[["colour"]]) |
|||
} else { |
|||
clvls <- levels(factor(data[["colour"]])) |
|||
} |
|||
|
|||
if (!("colour" %in% names(data))) { |
|||
data[["colour"]] <- "white" |
|||
} else { |
|||
if (any(is.na(as.character(data[["colour"]])))) { |
|||
data[["colour"]] <- "white" |
|||
} else { |
|||
data[["colour"]] <- as.character(data[["colour"]]) |
|||
} |
|||
} |
|||
|
|||
p <- split(data, data$PANEL) |
|||
|
|||
lapply(p, function(.x) { |
|||
|
|||
if (params[["make_proportional"]]) { |
|||
.x[["values"]] <- .x[["values"]] / sum(.x[["values"]]) |
|||
.x[["values"]] <- round_preserve_sum(.x[["values"]], digits = 2) |
|||
.x[["values"]] <- as.integer(.x[["values"]] * 100) |
|||
} |
|||
|
|||
parts_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
rep(as.character(.x[[use]][i]), .x[["values"]][i]) |
|||
})) |
|||
|
|||
pgrp_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
rep(.x$group, .x[["values"]][i]) |
|||
})) |
|||
|
|||
# print(str(.x, 1)) |
|||
|
|||
colour_vec <- unlist(sapply(1:length(.x[[use]]), function(i) { |
|||
rep(.x[["colour"]][i], .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))) |
|||
colour_vec <- c(colour_vec, rep(NA, nrow(tdf)-length(colour_vec))) |
|||
|
|||
# tdf$parts <- parts_vec |
|||
tdf[["values"]] <- NA |
|||
tdf[["colour"]] <- colour_vec |
|||
tdf[[use]] <- parts_vec |
|||
tdf[["PANEL"]] <- .x[["PANEL"]][1] |
|||
tdf[["group"]] <- 1:nrow(tdf) |
|||
|
|||
tdf <- tdf[sapply(tdf[[use]], function(x) !is.na(x)),] |
|||
|
|||
}) -> p |
|||
|
|||
p <- plyr::rbind.fill(p) |
|||
p[[use]] <- factor(p[[use]], levels=flvls) |
|||
p[["colour"]] <- factor(p[["colour"]], levels = clvls) |
|||
|
|||
# print(str(p, 1)) |
|||
# |
|||
# msg("Done With => StatWaffle::setup_data()") |
|||
# data |
|||
|
|||
wdat <- p |
|||
|
|||
if (params$flip) { |
|||
x_temp <- wdat$x |
|||
wdat$x <- wdat$y |
|||
wdat$y <- x_temp |
|||
x_temp <- NULL |
|||
} |
|||
|
|||
wdat$width <- wdat$width %||% params$width %||% ggplot2::resolution(wdat$x, FALSE) |
|||
wdat$height <- wdat$height %||% params$height %||% ggplot2::resolution(wdat$y, FALSE) |
|||
|
|||
transform( |
|||
wdat, |
|||
xmin = x - width / 2, |
|||
xmax = x + width / 2, |
|||
width = NULL, |
|||
ymin = y - height / 2, |
|||
ymax = y + height / 2, |
|||
height = NULL |
|||
) -> p |
|||
|
|||
p |
|||
|
|||
}, |
|||
|
|||
compute_layer = function(self, data, params, layout) { |
|||
# msg("Called => StatWaffle::compute_layer()") |
|||
# print(str(data, 1)) |
|||
# print(str(params, 1)) |
|||
# msg("Done With => StatWaffle::compute_layer()") |
|||
data |
|||
}, |
|||
|
|||
finish_layer = function(self, data, params) { |
|||
# msg("Called => StatWaffle::finish_layer()") |
|||
# msg("Done With => StatWaffle::finish_layer()") |
|||
data |
|||
}, |
|||
|
|||
compute_panel = function(self, data, scales, ...) { |
|||
# msg("Called => StatWaffle::compute_panel()") |
|||
# msg("Done With => StatWaffle::compute_panel()") |
|||
data |
|||
} |
|||
|
|||
) |
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
|||
|
Before Width: | Height: | Size: 60 KiB After Width: | Height: | Size: 60 KiB |
Before Width: | Height: | Size: 108 KiB After Width: | Height: | Size: 106 KiB |
@ -1,90 +0,0 @@ |
|||
% Generated by roxygen2: do not edit by hand |
|||
% Please edit documentation in R/geom-pictogram.R, R/stat-pictogram.R |
|||
\docType{data} |
|||
\name{geom_pictogram} |
|||
\alias{geom_pictogram} |
|||
\alias{GeomPictogram} |
|||
\alias{stat_pictogram} |
|||
\alias{StatPictogram} |
|||
\title{Isotype pictogram "waffle" charts} |
|||
\format{An object of class \code{GeomPictogram} (inherits from \code{Geom}, \code{ggproto}, \code{gg}) of length 8.} |
|||
\usage{ |
|||
geom_pictogram(mapping = NULL, data = NULL, n_rows = 10, |
|||
flip = FALSE, make_proportional = FALSE, fa_key = NA, |
|||
na.rm = TRUE, show.legend = NA, inherit.aes = TRUE, ...) |
|||
|
|||
GeomPictogram |
|||
|
|||
stat_pictogram(mapping = NULL, data = NULL, n_rows = 10, |
|||
make_proportional = FALSE, na.rm = NA, show.legend = NA, |
|||
fa_key = NA, inherit.aes = TRUE, ...) |
|||
|
|||
StatPictogram |
|||
} |
|||
\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{flip}{If \code{TRUE}, flip x and y coords. n_rows then becomes n_cols. |
|||
Useful to achieve waffle column chart effect. Defaults is \code{FALSE}.} |
|||
|
|||
\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{colour} (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) |
|||
} |
|||
} |
|||
\examples{ |
|||
data.frame( |
|||
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_pictogram() + |
|||
facet_wrap(~fct) + |
|||
coord_equal() |
|||
} |
|||
\keyword{datasets} |
@ -0,0 +1,2 @@ |
|||
*.html |
|||
*.R |
@ -0,0 +1,332 @@ |
|||
--- |
|||
title: "Building Waffle Charts" |
|||
output: rmarkdown::html_vignette |
|||
vignette: > |
|||
%\VignetteIndexEntry{Building Waffle Charts} |
|||
%\VignetteEngine{knitr::rmarkdown} |
|||
%\VignetteEncoding{UTF-8} |
|||
--- |
|||
|
|||
```{r setup, include=FALSE} |
|||
knitr::opts_chunk$set( |
|||
echo = TRUE, message = FALSE, warning = FALSE, |
|||
fig.width = 8, fig.height = 6, out.width = "100%" |
|||
) |
|||
``` |
|||
|
|||
```{r libs} |
|||
library(hrbrthemes) |
|||
library(waffle) |
|||
library(ggplot2) |
|||
library(dplyr) |
|||
``` |
|||
|
|||
### Our example data |
|||
|
|||
```{r data} |
|||
three_states <- sample(state.name, 3) |
|||
|
|||
data.frame( |
|||
states = factor(rep(three_states, 3), levels = three_states), |
|||
vals = c(10, 20, 30, 6, 14, 40, 30, 20, 10), |
|||
col = rep(c("blue", "black", "red"), 3), |
|||
fct = c(rep("Thing 1", 3), rep("Thing 2", 3), rep("Thing 3", 3)) |
|||
) -> xdf |
|||
|
|||
xdf |
|||
``` |
|||
|
|||
### Single waffle setup |
|||
|
|||
We'll use this as a base for some of the examples to enable focusing on tweaking the contents of `geom_waffle()`: |
|||
|
|||
```{r base} |
|||
xdf %>% |
|||
count(states, wt = vals) %>% |
|||
ggplot(aes(fill = states, values = n)) + |
|||
expand_limits(x=c(0,0), y=c(0,0)) + |
|||
coord_equal() + |
|||
labs(fill = NULL, colour = NULL) + |
|||
theme_ipsum_rc(grid="") + |
|||
theme_enhance_waffle() -> waf |
|||
``` |
|||
|
|||
### Plain waffles |
|||
|
|||
```{r plain} |
|||
waf + |
|||
geom_waffle( |
|||
n_rows = 20, size = 0.33, colour = "white", flip = TRUE |
|||
) |
|||
``` |
|||
|
|||
### Proportional waffles |
|||
|
|||
This likely should be the default. Waffles work best when they are square (makes it easier to compare parts to whole which is the purpose of the chart). You could do this normalization prior to passing data into `geom_waffle()` or let it do it for you with the `make_proportional` parameter. |
|||
|
|||
```{r prop} |
|||
waf + |
|||
geom_waffle( |
|||
n_rows = 10, size = 0.33, colour = "white", flip = TRUE, |
|||
make_proportional = TRUE |
|||
) |
|||
``` |
|||
|
|||
### Thicker lines |
|||
|
|||
Need to be careful as this can shift perception to the background grid vs the data encoding you're trying to present. |
|||
|
|||
```{r bigger-lines} |
|||
waf + |
|||
geom_waffle( |
|||
n_rows = 10, size = 3, colour = "white", |
|||
make_proportional = TRUE |
|||
) |
|||
``` |
|||
|
|||
### Changing the line color |
|||
|
|||
You can use this to match any background you're going to use or to just provide a different aesthetic feel. Note that the same problem can occur here as in the "bigger lines" case and attention can be inadvertedly shifted to the grid lines vs the colored proportions. |
|||
|
|||
```{r color-change-1} |
|||
waf + |
|||
geom_waffle( |
|||
n_rows = 10, size = 0.33, colour = "black", |
|||
make_proportional = TRUE |
|||
) |
|||
``` |
|||
|
|||
We can also "fill in the lines" but that pretty much makes it not a waffle chart: |
|||
|
|||
```{r color-change-2} |
|||
waf + |
|||
geom_waffle( |
|||
aes(colour = states), |
|||
n_rows = 10, size = 0.33, make_proportional = TRUE |
|||
) |
|||
``` |
|||
|
|||
You can also map the `colour` aesthetic to a column which can help make a "highlight" effect, but that's going to also contribute to perception skew: |
|||
|
|||
```{r color-change-3} |
|||
waf + |
|||
geom_waffle( |
|||
aes(colour = states), |
|||
n_rows = 10, size = 0.45, make_proportional = TRUE |
|||
) + |
|||
scale_colour_manual( |
|||
values = c(alpha("black", 1/3), "black", alpha("black", 1/3)) |
|||
) |
|||
``` |
|||
|
|||
You can possibly correct for perception skew by shrinking the width and the height of each cell to make some room for the strokes: |
|||
|
|||
```{r color-change-4} |
|||
waf + |
|||
geom_waffle( |
|||
aes(colour = states), |
|||
n_rows = 10, size = 0.3, make_proportional = TRUE, |
|||
height = 0.9, width = 0.9 |
|||
) + |
|||
scale_colour_manual( |
|||
values = c("white", "black", "white") |
|||
) |
|||
``` |
|||
|
|||
You might be better off just changing the alpha value's though: |
|||
|
|||
```{r color-change-5} |
|||
waf + |
|||
geom_waffle( |
|||
n_rows = 10, size = 0.3, make_proportional = TRUE, |
|||
height = 0.9, width = 0.9 |
|||
) + |
|||
scale_fill_manual( |
|||
values = c(alpha("#f8766d", 1/3), "#00ba38", alpha("#619cff", 1/3)) |
|||
) |
|||
``` |
|||
|
|||
### Hip to not be square? |
|||
|
|||
To mix things up you can also round out the corners by specifying a `grid::unit()` value to the `radius` parameter. This isn't generally recommended as the goal is to enable quick mental perception for parts to whole and the rounded corners can delay and/or skew said interpretation. |
|||
|
|||
Here that is with and without proportional waffles: |
|||
|
|||
```{r round-one} |
|||
waf + |
|||
geom_waffle( |
|||
n_rows = 10, size = 0.5, colour = "white", |
|||
make_proportional = TRUE, |
|||
radius = unit(4, "pt") |
|||
) |
|||
``` |
|||
|
|||
```{r round-two} |
|||
waf + |
|||
geom_waffle( |
|||
n_rows = 10, size = 0.5, colour = "white", |
|||
radius = unit(4, "pt") |
|||
) |
|||
``` |
|||
|
|||
Also, think twice when changing the stroke color as it continues to contribute to perception skew. Consider shrinking the cells to add more space between them if you choose to do this: |
|||
|
|||
```{r round-three} |
|||
waf + |
|||
geom_waffle( |
|||
n_rows = 10, size = 1, colour = "black", |
|||
make_proportional = TRUE, |
|||
radius = unit(4, "pt"), |
|||
height = 0.8, width = 0.8 |
|||
) |
|||
``` |
|||
|
|||
You can also use this for the same highlight effect as above: |
|||
|
|||
```{r round-four} |
|||
waf + |
|||
geom_waffle( |
|||
aes(colour = states), |
|||
n_rows = 10, size = 0.4, make_proportional = TRUE, |
|||
radius = unit(4, "pt"), |
|||
height = 0.9, width = 0.9 |
|||
) + |
|||
scale_colour_manual( |
|||
values = c("black", "white", "white") |
|||
) |
|||
``` |
|||
|
|||
```{r round-five} |
|||
waf + |
|||
geom_waffle( |
|||
n_rows = 10, size = 1, color = "white", make_proportional = TRUE, |
|||
radius = unit(4, "pt"), |
|||
height = 1, width = 1 |
|||
) + |
|||
scale_fill_manual( |
|||
values = c("#f8766d", alpha("#00ba38", 1/3), alpha("#619cff", 1/3)) |
|||
) |
|||
``` |
|||
|
|||
### Basic waffle bar chart |
|||
|
|||
You can make a bar-like chart with the waffles by using facet wrapping and hacking on strip spacing: |
|||
|
|||
```{r waffle-bar} |
|||
waf + |
|||
geom_waffle( |
|||
n_rows = 5, color = "white", show.legend = FALSE, flip = TRUE |
|||
) + |
|||
facet_wrap(~states) + |
|||
theme(panel.spacing.x = unit(0, "npc")) + |
|||
theme(strip.text.x = element_text(hjust = 0.5)) |
|||
``` |
|||
|
|||
### Waffle buffet setup |
|||
|
|||
Since you now know we can use faceting, we can go all sorts of crazy. We'll do another setup for this waffle buffet: |
|||
|
|||
```{r waffle-buffet-setup} |
|||
xdf %>% |
|||
ggplot(aes(fill = states, values = vals)) + |
|||
expand_limits(x=c(0,0), y=c(0,0)) + |
|||
coord_equal() + |
|||
labs(fill = NULL, colour = NULL) + |
|||
theme_ipsum_rc(grid="") + |
|||
theme_enhance_waffle() -> buf |
|||
``` |
|||
|
|||
### Faceting using another variable |
|||
|
|||
If you have parts-of-a-whole groups you want to compare across observations you can facet on another variable |
|||
|
|||
```{r waffle-buffet} |
|||
buf + |
|||
geom_waffle( |
|||
color = "white", size = 0.33 |
|||
) + |
|||
facet_wrap(~fct) + |
|||
theme(strip.text.x = element_text(hjust = 0.5)) |
|||
``` |
|||
|
|||
Again, waffles generally work better when they are square and each one sums to 100 and this is even more true in a buffet grid of waffles: |
|||
|
|||
```{r waffle-buffet-prop} |
|||
buf + |
|||
geom_waffle( |
|||
color = "white", size = 0.33, |
|||
make_proportional = TRUE, n_rows = 10 |
|||
) + |
|||
facet_wrap(~fct) + |
|||
theme(legend.position = "bottom") + |
|||
theme(strip.text.x = element_text(hjust = 0.5)) |
|||
``` |
|||
|
|||
They can be rounded tiles as well: |
|||
|
|||
```{r waffle-buffet-round} |
|||
buf + |
|||
geom_waffle( |
|||
color = "white", size = 0.33, |
|||
make_proportional = TRUE, n_rows = 10, |
|||
radius = unit(2, "pt") |
|||
) + |
|||
facet_wrap(~fct) + |
|||
theme(legend.position = "bottom") + |
|||
theme(strip.text.x = element_text(hjust = 0.5)) |
|||
``` |
|||
|
|||
And, you can do the highlight hack: |
|||
|
|||
```{r waffle-buffet-high} |
|||
buf + |
|||
geom_waffle( |
|||
color = "white", size = 0.33, |
|||
make_proportional = TRUE, n_rows = 10, |
|||
radius = unit(2, "pt") |
|||
) + |
|||
facet_wrap(~fct) + |
|||
scale_fill_manual( |
|||
values = c("#f8766d", alpha("#00ba38", 1/3), alpha("#619cff", 1/3)) |
|||
) + |
|||
theme(legend.position = "bottom") + |
|||
theme(strip.text.x = element_text(hjust = 0.5)) |
|||
``` |
|||
|
|||
If you aren't going to use proportional waffle buffet charts consider altering the aesthetics to make them waffle bars instead: |
|||
|
|||
```{r waffle-buffet-bars} |
|||
buf + |
|||
geom_waffle( |
|||
color = "white", size = 0.33, n_rows = 4, flip = TRUE |
|||
) + |
|||
facet_wrap(~fct) + |
|||
theme(legend.position = "bottom") + |
|||
theme(strip.text.x = element_text(hjust = 0.5)) |
|||
``` |
|||
|
|||
### Over the top |
|||
|
|||
```{r over-the-top} |
|||
storms %>% |
|||
filter(year >= 2010) %>% |
|||
count(year, status) -> storms_df |
|||
|
|||
ggplot(storms_df, aes(fill = status, values = n)) + |
|||
geom_waffle(color = "white", size = .25, n_rows = 10, flip = TRUE) + |
|||
facet_wrap(~year, nrow = 1, strip.position = "bottom") + |
|||
scale_x_discrete() + |
|||
scale_y_continuous(labels = function(x) x * 10, # make this multiplyer the same as n_rows |
|||
expand = c(0,0)) + |
|||
ggthemes::scale_fill_tableau(name=NULL) + |
|||
coord_equal() + |
|||
labs( |
|||
title = "Faceted Waffle Bar Chart", |
|||
subtitle = "{dplyr} storms data", |
|||
x = "Year", |
|||
y = "Count" |
|||
) + |
|||
theme_minimal(base_family = "Roboto Condensed") + |
|||
theme(panel.grid = element_blank(), axis.ticks.y = element_line()) + |
|||
guides(fill = guide_legend(reverse = TRUE)) |
|||
``` |
Loading…
Reference in new issue