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")) |
|||
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 | |||