You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
98 lines
2.4 KiB
98 lines
2.4 KiB
# #' @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
|
|
# )
|
|
#
|
|
# }
|
|
#
|
|
# )
|
|
#
|