boB Rudis
5 years ago
11 changed files with 594 additions and 27 deletions
@ -0,0 +1,233 @@ |
|||
#' @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,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 = 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"), |
|||
# |
|||
# 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) |
|||
# |
|||
# } |
|||
# |
|||
# ) |
@ -0,0 +1,142 @@ |
|||
#' @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") |
|||
} |
|||
|
|||
|
|||
) |
@ -0,0 +1,90 @@ |
|||
% 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} |
Loading…
Reference in new issue