在 ggplot2 中创建带有构面的华夫饼图
Creating a waffle plot together with facets in ggplot2
有没有什么简单的方法可以结合 ggplot2 中的方面创建华夫饼图，或者结合华夫饼包？
例如，将下面的每个条替换为 100 个正方形代表 1%。
ggplot(mtcars, aes(x = factor(vs), y = hp, fill = as.factor(carb))) +
geom_bar(stat = 'identity', position = 'fill') +
facet_wrap('gear')
我不确定我是否会抽空 stat_waffle() / geom_waffle() 但您可以使用包中的逻辑从头到尾做同样的事情：
library(hrbrthemes)
library(tidyverse)
我们需要计算出百分比，然后让每个组的总和等于 100，所以我们需要一个已经在 SO 上使用了一段时间的辅助函数：
smart_round <- function(x, digits = 0) { # somewhere on SO
up <- 10 ^ digits
x <- x * up
y <- floor(x)
indices <- tail(order(x-y), round(sum(x)) - sum(y))
y[indices] <- y[indices] + 1
y / up
}
waffle包中有2位"magic"。一位是算法的一部分，它只是将因子分量复制到正确的次数。我们将按行将以下函数应用于我们将制作的数据框：
waffleize <- function(xdf) {
data_frame(
gear_vs = rep(xdf$gear_vs, xdf$pct),
carb = rep(xdf$carb, xdf$pct)
)
}
现在我们需要：
- 用 ggplot2 为你的例子做同样的数学运算
- 计算组的百分比
- 将%化为100的一部分，使每组合计为100
- 因为我们不能在一个面板中有两个不同的
geom_tile()，我们需要破解一个可以做同样事情的方面名称
- 按上述 hack 分组
- 每行重复
pct 次
- 确保一切有序
- 加入一个 10x10
x/y 网格，我们将拥有尽可能多的面（在本例中为 6）；这是华夫饼包装的另一部分 "magic"
- 绘制方块
^^ 转换为（这个管链是 wee 有点长，但 "it works"） :
count(mtcars, gear, vs, carb, wt=hp) %>%
group_by(gear, vs) %>%
mutate(pct = n/sum(n)) %>%
mutate(pct = (smart_round(pct, 1) * 100L) %>% as.integer()) %>%
select(-n) %>%
ungroup() %>%
mutate(carb = as.character(carb)) %>%
mutate(gear_vs = sprintf("%s-%s", gear, vs)) %>%
select(gear_vs, carb, pct, -gear, -vs) %>%
rowwise() %>%
do(waffleize(.)) %>%
ungroup() %>%
arrange(gear_vs, carb) %>%
bind_cols(
map_df(seq_len(length(unique(.$gear_vs))), ~expand.grid(y = 1:10, x = 1:10))
) %>%
ggplot(aes(x, y)) +
geom_tile(aes(fill=carb), color="white", size=0.5) +
ggthemes::scale_fill_tableau() +
facet_wrap(~gear_vs) +
coord_equal() +
labs(x=NULL, y = NULL) +
hrbrthemes::theme_ipsum_rc(grid="") +
theme(axis.text=element_blank())
@hrbrmstr 出色答案的一点补充（感谢您制作软件包并与我们分享代码！）。我也一直在努力绘制这样的图，因为我认为在进行比较时，这是比饼图更好的可视化数据的方法。我对华夫饼图表的看法在三个方面不同于现有的解决方案 (waffle and ggwaffle)：
- 华夫饼应始终以纵横比为 1 的 10x10% 网格呈现，如要求的 OP 问题和@hrbrmstr 答案中所述。这使得阅读百分比更容易。
- 华夫饼应从左到右（阅读方向）和从下向上（与现有解决方案不同，就像玻璃杯中的水一样）填充。这让我更自然地阅读百分比。
- 可以划分 1% 的单元格以容纳小数百分比。使用完整百分比时贡献 <1% 的组消失，但在我使用这些图的应用程序中，缺失组与 (0,1) 组具有不同的含义。
因为解决上面提到的问题花了我不少时间，所以我post下我的解决方案。 "The magic"（即方法）代码背后已从现有包中清除。我希望这对某人有所帮助并推动华夫饼图的发展。我真的认为这些图表在数据可视化方面具有潜力。将函数实现为 ggplot2 proto 对象会很好，但在尝试之后我不得不放弃。我不了解 proto 系统是否足够好，无法为其编写代码。我只是复制我打算包含在 R package once I have added all the features I plan to add (the plan is to make waffle charts work similarly to scatterpie) 中的代码。请注意，下面的很多代码都是为了让华夫饼变得漂亮。实际烘烤华夫饼的部分并不复杂，在@hrbrmstr 的回答中有很好的解释。
运行 示例所需的函数：
library(dplyr)
library(ggplot2)
#' @title Convert line sizes measured as points to ggplot line sizes
#' @description Converts line sizes measured as points (as given by most programs such as Adobe Illustrator etc.) to ggplot font sizes
#' @param x numeric vector giving the lines sizes in points
#' @return Returns a numeric vector of lenght \code{x} of ggplot line sizes
#' @keywords internal
#' @export
#'
LS <- function(x) x/2.13
#' @title Round values preserving total sums
#' @description The function rounds values preserving total sums
#' @param x numeric vector of values to be rounded
#' @param digits integer indicating the number of decimal places. See \code{\link[base]{round}}.
#' @return Returns a numeric vector.
#' @author The function is written as a communal effort. Main authors are \href{ and \href{https://www.r-bloggers.com/round-values-while-preserve-their-rounded-sum-in-r/}{BioStatMatt}.
#' @keywords internal
#' @family waffle
#' @export
round_preserve_sum <- function(x, digits = 0) {
up <- 10 ^ digits
x <- x * up
y <- floor(x)
indices <- tail(order(x-y), round(sum(x)) - sum(y))
y[indices] <- y[indices] + 1
y / up
} # from https://www.r-bloggers.com/round-values-while-preserve-their-rounded-sum-in-r/
#' @title Prepare data for waffle plots
#' @description Manipulates a data frame ready for plotting with the \code{\link{waffle_chart}} function.
#' @param dt data frame containing the data which should be transformed
#' @param fill character specifying the column name which should be used as fill for the waffle plot.
#' @param value character specifying the column name which contains values of the \code{fill} variable.
#' @param composition logical indicating whether a compositional waffle (i.e. fill adds up to 100\%) should be created. If \code{FALSE}, waffle cells will be scaled to \code{max_value} and missing cells filled with an "empty" category.
#' @param max_value numerical giving the value to which waffle cells should be scaled to, if \code{composition = FALSE}.
#' @param digits integer indicating the number of decimal places to be used in rounding of the waffle cells.
#' @return returns a \link[tibble]{tibble} data frame containing the minimum and maximum extent of each \code{fill} level.
#' @author Mikko Vihtakari
#' @keywords internal
#' @family waffle
#' @import dplyr
#' @export
waffleize <- function(dt, fill, value, composition = TRUE, max_value = NULL, digits = 3) {
x <- dt[c(fill, value)]
names(x) <- c("variable", "value")
if(composition) {
x$value <- round_preserve_sum(10^digits*x$value/sum(x$value))
} else {
if(is.null(max_value)) stop("max_value has to be given, if composition = FALSE")
if(max_value < sum(x$value)) stop("max_value has to be larger than the sum of 'value' column. Use composition = TRUE, if you want a compositional waffle chart")
x <- rbind(x, data.frame(variable = "empty", value = max_value - sum(x$value)))
x$value <- round_preserve_sum(10^digits*x$value/max_value)
}
if(!is.factor(x$variable)) x$variable <- factor(x$variable, levels = c(sort(unique(x$variable)[unique(x$variable) != "empty"]), "empty"))
x <- x[order(x$variable),]
#tmp <- data.frame(X = 1:100, ymin = rep(c(0, (1:9)*10), each = 100), ymax = rep((1:10)*10, each = 100), variable = rep(dt[[fill]], dt[[value]]))
tmp <- data.frame(X = 1:10^(digits-1), ymin = rep(c(0, (1:9)*10^(digits-2)), each = 10^(digits-1)), ymax = rep((1:10)*10^(digits-2), each = 10^(digits-1)), variable = rep(x$variable, x$value))
out <- tmp %>% group_by(variable, ymin, ymax) %>% summarise(xmin = min(X)-1, xmax = max(X))
## Remove the empty category
out[out$variable != "empty",]
}
#' @title Plot waffle charts
#' @description The function uses \link[ggplot2]{ggplot2} to create waffle charts from data.
#' @param data data frame to be plotted
#' @param fill character specifying the column name which should be used as fill for the waffle plot.
#' @param value character specifying the column name which contains values of the \code{fill} variable. Will be used to fill the waffle cells.
#' @param facet character specifying the column name which should be used to \code{\link[ggplot2]{facet_wrap}} waffle charts.
#' @param ncol number of columns to be used in facetting. See \code{\link[ggplot2]{facet_wrap}}.
#' @param composition logical indicating whether a compositional waffle (i.e. fill adds up to 100\%) should be created. If \code{FALSE}, waffle cells will be scaled to \code{max_value} and missing cells filled with an "empty" category.
#' @param max_value numerical giving the value to which waffle cells should be scaled to, if \code{composition = FALSE}.
#' @param digits integer indicating the number of decimal places to be used in rounding of the waffle cells. The value 3 indicates percentages, while 4 permilles.
#' @param fill_colors named character vector giving the colors for \code{fill} levels. See \code{\link[ggplot2]{scale_fill_manual}}.
#' @param fill_title character giving the title for the color legend.
#' @param base_size numeric giving the base size for the plot. See \code{\link[ggplot2]{theme_void}}.
#' @param legend.position character specifying the position of the legend. See \code{\link[ggplot2]{ggtheme}}.
#' @details The waffle charts are read from left to right (like text) and from bottom upwards (like water glass). The cells indicate 1\% of the maximum value (100% if \code{composition = TRUE} else \code{max_value}). The cells are divided vertically to fractions specifies by the \code{digits} argument.
#' @return Returns a \link[ggplot2]{ggplot2} waffle plot
#' @import ggplot2 dplyr
#' @family waffle
#' @author Mikko Vihtakari with code ideas from \href{https://github.com/hrbrmstr/waffle}{hrbrmstr} and \href{https://github.com/liamgilbey/ggwaffle}{Liam Gilbey}
#' @export
# data = dt; fill = "variable"; value = "value"; facet = NULL; composition = TRUE; max_value = NULL; digits = 3; fill_colors = NULL; fill_title = NULL; ncol = NULL; base_size = 12; legend.position = "bottom"
waffle_chart <- function(data, fill, value = "value", facet = NULL, composition = TRUE, max_value = NULL, digits = 3, fill_colors = NULL, fill_title = NULL, ncol = NULL, base_size = 12, legend.position = "bottom") {
## White 1% grid
grid_data <- data.frame(xmin = c(0,(1:9)*10^(digits-2)), xmax = (1:10)*10^(digits-2), ymin = rep(c(0,(1:9)*10^(digits-2)), each = 10^(digits-2)), ymax = rep((1:10)*10^(digits-2), each = 10^(digits-2)))
if(is.null(facet)) { ## No facetting
if(any(duplicated(data[[fill]]))) stop("data contains duplicated entries in fill column. Use the facet argument or summarize data before plotting.")
waffle_data <- waffleize(dt = data, fill = fill, value = value, composition = composition, max_value = max_value, digits = digits)
## Plot ####
p <- ggplot() +
geom_rect(data = waffle_data, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = variable)) +
geom_rect(data = grid_data, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax), fill = NA, color = "white") +
coord_equal(expand = FALSE) +
theme_void()
## ####
} else { ## Facetting
waffle_data <- data %>% group_by_(facet) %>% do(waffleize(dt = ., fill = fill, value = value, composition = composition, max_value = max_value, digits = digits))
## Plot ####
p <- ggplot() +
geom_rect(data = waffle_data, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = variable)) +
geom_rect(data = grid_data, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax), fill = NA, color = "white") +
facet_wrap(facet, ncol = ncol) +
coord_equal(expand = FALSE) +
theme_void()
## ####
}
## Fill colors ####
if(is.null(fill_title)) fill_title <- "Variable"
if(!is.null(fill_colors)) {
p <- p + scale_fill_manual(name = fill_title, values = fill_colors)
} else {
p <- p + scale_fill_viridis_d(name = fill_title)
}
## Final theme manipulation
p <- p + theme(
legend.position = legend.position,
aspect.ratio = 1,
panel.border = element_rect(color = "black", size = LS(1), fill = NA),
strip.background = element_rect(fill = alpha("white", 0.4), color = NA),
strip.text.x = element_text(size = base_size*0.8, margin = margin(t = 2, r = 0, b = 3, l = 0, unit = "pt")),
plot.title = element_text(size = base_size, hjust = 0.5, face = 2),
legend.background = element_blank(),
legend.box.background = element_blank(),
legend.title = element_text(size = base_size),
legend.text = element_text(size = base_size),
plot.background = element_blank(),
panel.spacing = unit(0.2, units = "line"),
legend.box.margin = margin(t = 0, r = 0, b = 3, l = 0, unit = "pt"),
plot.margin = unit(c(0.2, 0.5, 0.1, 0.1), units = "line")
)
## Return the plot
p
}
终于可以制作图表了：
# Manipulate the dataset first to make sure that there are no replicate
# entries of factors used for the waffles
data("mtcars")
mtcars$gear_vs <- paste(mtcars$gear, mtcars$vs, sep = "-")
mtcars$carb <- factor(mtcars$carb)
x <- mtcars %>% group_by(gear_vs, carb) %>% summarise(value = sum(hp))
waffle_chart(x, fill = "carb", facet = "gear_vs", value = "value")
## You can also scale the waffles to a maximum hp in gear_vs
y <- x %>% group_by(gear_vs) %>% summarise(value = sum(value))
waffle_chart(x, fill = "carb", facet = "gear_vs", value = "value", composition = FALSE, max_value = max(y$value))
这是另一种方法，仅使用 tidyverse（即 dplyr、tidyr 和 ggplot2）来创建 华夫饼图 或 方形饼图 。它基于 ，但我试图让它更通用一些；任何频率 table 都可以作为输入，并且很容易调整华夫饼的尺寸（例如矩形而不是正方形）。
library(tidyverse)
freq_table = mtcars %>%
count(gear, vs, carb, wt = hp) %>%
group_by(gear, vs) %>%
mutate(pct = n / sum(n)) %>%
select(gear, vs, carb, pct)
第二步创建坐标。使用 tidyr::expand() 而不是 waffleize()。仍在使用 smart_round().
waffle.n = 100 # Number of blocks
waffle.cols = ceiling(sqrt(waffle.n)) # For square. Otherwise pick integer.
coordinates = freq_table %>%
group_by(gear, vs) %>%
mutate(waffle.num = smart_round(pct,1) * waffle.n) %>%
group_by(carb, gear, vs) %>%
expand(count = seq(1:waffle.num)) %>%
select(-count) %>%
group_by(gear, vs) %>%
arrange(gear, vs) %>%
mutate(
waffle.x = rep_len(1:waffle.cols, waffle.n),
waffle.y = floor((row_number() - 1) / waffle.cols)
)
我按两个变量（gear 和 vs）分组，因此使用 facet_grid()。如果您按单个变量分组，则使用 facet_wrap()。您需要稍微调整选项以获得最佳结果（例如设备的大小，或点的大小和笔划）。
fig = coordinates %>%
ggplot(aes(x = waffle.x, y = waffle.y, fill = as.factor(carb))) +
geom_point(size = 7, shape = 22, color = "white", stroke = 0.8) +
#geom_raster() + # Alternative to geom_point() without gap between blocks.
facet_grid(rows = vars(gear), cols = vars(vs)) +
theme_void() +
theme(legend.position = "bottom", plot.margin = margin(5.5, 5.5, 5.5, 5.5, "pt"), panel.spacing = unit(15, "pt"))
fig
#ggsave("fig.pdf", width = 13, height = 17.5, units = "cm", dpi = 150)
A more interesting example块数不均匀且份额不能被10整除。
有没有什么简单的方法可以结合 ggplot2 中的方面创建华夫饼图，或者结合华夫饼包？
例如，将下面的每个条替换为 100 个正方形代表 1%。
ggplot(mtcars, aes(x = factor(vs), y = hp, fill = as.factor(carb))) +
geom_bar(stat = 'identity', position = 'fill') +
facet_wrap('gear')
我不确定我是否会抽空 stat_waffle() / geom_waffle() 但您可以使用包中的逻辑从头到尾做同样的事情：
library(hrbrthemes)
library(tidyverse)
我们需要计算出百分比，然后让每个组的总和等于 100，所以我们需要一个已经在 SO 上使用了一段时间的辅助函数：
smart_round <- function(x, digits = 0) { # somewhere on SO
up <- 10 ^ digits
x <- x * up
y <- floor(x)
indices <- tail(order(x-y), round(sum(x)) - sum(y))
y[indices] <- y[indices] + 1
y / up
}
waffle包中有2位"magic"。一位是算法的一部分，它只是将因子分量复制到正确的次数。我们将按行将以下函数应用于我们将制作的数据框：
waffleize <- function(xdf) {
data_frame(
gear_vs = rep(xdf$gear_vs, xdf$pct),
carb = rep(xdf$carb, xdf$pct)
)
}
现在我们需要：
- 用 ggplot2 为你的例子做同样的数学运算
- 计算组的百分比
- 将%化为100的一部分，使每组合计为100
- 因为我们不能在一个面板中有两个不同的
geom_tile()，我们需要破解一个可以做同样事情的方面名称 - 按上述 hack 分组
- 每行重复
pct次 - 确保一切有序
- 加入一个 10x10
x/y网格，我们将拥有尽可能多的面（在本例中为 6）；这是华夫饼包装的另一部分 "magic" - 绘制方块
^^ 转换为（这个管链是 wee 有点长，但 "it works"） :
count(mtcars, gear, vs, carb, wt=hp) %>%
group_by(gear, vs) %>%
mutate(pct = n/sum(n)) %>%
mutate(pct = (smart_round(pct, 1) * 100L) %>% as.integer()) %>%
select(-n) %>%
ungroup() %>%
mutate(carb = as.character(carb)) %>%
mutate(gear_vs = sprintf("%s-%s", gear, vs)) %>%
select(gear_vs, carb, pct, -gear, -vs) %>%
rowwise() %>%
do(waffleize(.)) %>%
ungroup() %>%
arrange(gear_vs, carb) %>%
bind_cols(
map_df(seq_len(length(unique(.$gear_vs))), ~expand.grid(y = 1:10, x = 1:10))
) %>%
ggplot(aes(x, y)) +
geom_tile(aes(fill=carb), color="white", size=0.5) +
ggthemes::scale_fill_tableau() +
facet_wrap(~gear_vs) +
coord_equal() +
labs(x=NULL, y = NULL) +
hrbrthemes::theme_ipsum_rc(grid="") +
theme(axis.text=element_blank())
@hrbrmstr 出色答案的一点补充（感谢您制作软件包并与我们分享代码！）。我也一直在努力绘制这样的图，因为我认为在进行比较时，这是比饼图更好的可视化数据的方法。我对华夫饼图表的看法在三个方面不同于现有的解决方案 (waffle and ggwaffle)：
- 华夫饼应始终以纵横比为 1 的 10x10% 网格呈现，如要求的 OP 问题和@hrbrmstr 答案中所述。这使得阅读百分比更容易。
- 华夫饼应从左到右（阅读方向）和从下向上（与现有解决方案不同，就像玻璃杯中的水一样）填充。这让我更自然地阅读百分比。
- 可以划分 1% 的单元格以容纳小数百分比。使用完整百分比时贡献 <1% 的组消失，但在我使用这些图的应用程序中，缺失组与 (0,1) 组具有不同的含义。
因为解决上面提到的问题花了我不少时间，所以我post下我的解决方案。 "The magic"（即方法）代码背后已从现有包中清除。我希望这对某人有所帮助并推动华夫饼图的发展。我真的认为这些图表在数据可视化方面具有潜力。将函数实现为 ggplot2 proto 对象会很好，但在尝试之后我不得不放弃。我不了解 proto 系统是否足够好，无法为其编写代码。我只是复制我打算包含在 R package once I have added all the features I plan to add (the plan is to make waffle charts work similarly to scatterpie) 中的代码。请注意，下面的很多代码都是为了让华夫饼变得漂亮。实际烘烤华夫饼的部分并不复杂，在@hrbrmstr 的回答中有很好的解释。
运行 示例所需的函数：
library(dplyr)
library(ggplot2)
#' @title Convert line sizes measured as points to ggplot line sizes
#' @description Converts line sizes measured as points (as given by most programs such as Adobe Illustrator etc.) to ggplot font sizes
#' @param x numeric vector giving the lines sizes in points
#' @return Returns a numeric vector of lenght \code{x} of ggplot line sizes
#' @keywords internal
#' @export
#'
LS <- function(x) x/2.13
#' @title Round values preserving total sums
#' @description The function rounds values preserving total sums
#' @param x numeric vector of values to be rounded
#' @param digits integer indicating the number of decimal places. See \code{\link[base]{round}}.
#' @return Returns a numeric vector.
#' @author The function is written as a communal effort. Main authors are \href{ and \href{https://www.r-bloggers.com/round-values-while-preserve-their-rounded-sum-in-r/}{BioStatMatt}.
#' @keywords internal
#' @family waffle
#' @export
round_preserve_sum <- function(x, digits = 0) {
up <- 10 ^ digits
x <- x * up
y <- floor(x)
indices <- tail(order(x-y), round(sum(x)) - sum(y))
y[indices] <- y[indices] + 1
y / up
} # from https://www.r-bloggers.com/round-values-while-preserve-their-rounded-sum-in-r/
#' @title Prepare data for waffle plots
#' @description Manipulates a data frame ready for plotting with the \code{\link{waffle_chart}} function.
#' @param dt data frame containing the data which should be transformed
#' @param fill character specifying the column name which should be used as fill for the waffle plot.
#' @param value character specifying the column name which contains values of the \code{fill} variable.
#' @param composition logical indicating whether a compositional waffle (i.e. fill adds up to 100\%) should be created. If \code{FALSE}, waffle cells will be scaled to \code{max_value} and missing cells filled with an "empty" category.
#' @param max_value numerical giving the value to which waffle cells should be scaled to, if \code{composition = FALSE}.
#' @param digits integer indicating the number of decimal places to be used in rounding of the waffle cells.
#' @return returns a \link[tibble]{tibble} data frame containing the minimum and maximum extent of each \code{fill} level.
#' @author Mikko Vihtakari
#' @keywords internal
#' @family waffle
#' @import dplyr
#' @export
waffleize <- function(dt, fill, value, composition = TRUE, max_value = NULL, digits = 3) {
x <- dt[c(fill, value)]
names(x) <- c("variable", "value")
if(composition) {
x$value <- round_preserve_sum(10^digits*x$value/sum(x$value))
} else {
if(is.null(max_value)) stop("max_value has to be given, if composition = FALSE")
if(max_value < sum(x$value)) stop("max_value has to be larger than the sum of 'value' column. Use composition = TRUE, if you want a compositional waffle chart")
x <- rbind(x, data.frame(variable = "empty", value = max_value - sum(x$value)))
x$value <- round_preserve_sum(10^digits*x$value/max_value)
}
if(!is.factor(x$variable)) x$variable <- factor(x$variable, levels = c(sort(unique(x$variable)[unique(x$variable) != "empty"]), "empty"))
x <- x[order(x$variable),]
#tmp <- data.frame(X = 1:100, ymin = rep(c(0, (1:9)*10), each = 100), ymax = rep((1:10)*10, each = 100), variable = rep(dt[[fill]], dt[[value]]))
tmp <- data.frame(X = 1:10^(digits-1), ymin = rep(c(0, (1:9)*10^(digits-2)), each = 10^(digits-1)), ymax = rep((1:10)*10^(digits-2), each = 10^(digits-1)), variable = rep(x$variable, x$value))
out <- tmp %>% group_by(variable, ymin, ymax) %>% summarise(xmin = min(X)-1, xmax = max(X))
## Remove the empty category
out[out$variable != "empty",]
}
#' @title Plot waffle charts
#' @description The function uses \link[ggplot2]{ggplot2} to create waffle charts from data.
#' @param data data frame to be plotted
#' @param fill character specifying the column name which should be used as fill for the waffle plot.
#' @param value character specifying the column name which contains values of the \code{fill} variable. Will be used to fill the waffle cells.
#' @param facet character specifying the column name which should be used to \code{\link[ggplot2]{facet_wrap}} waffle charts.
#' @param ncol number of columns to be used in facetting. See \code{\link[ggplot2]{facet_wrap}}.
#' @param composition logical indicating whether a compositional waffle (i.e. fill adds up to 100\%) should be created. If \code{FALSE}, waffle cells will be scaled to \code{max_value} and missing cells filled with an "empty" category.
#' @param max_value numerical giving the value to which waffle cells should be scaled to, if \code{composition = FALSE}.
#' @param digits integer indicating the number of decimal places to be used in rounding of the waffle cells. The value 3 indicates percentages, while 4 permilles.
#' @param fill_colors named character vector giving the colors for \code{fill} levels. See \code{\link[ggplot2]{scale_fill_manual}}.
#' @param fill_title character giving the title for the color legend.
#' @param base_size numeric giving the base size for the plot. See \code{\link[ggplot2]{theme_void}}.
#' @param legend.position character specifying the position of the legend. See \code{\link[ggplot2]{ggtheme}}.
#' @details The waffle charts are read from left to right (like text) and from bottom upwards (like water glass). The cells indicate 1\% of the maximum value (100% if \code{composition = TRUE} else \code{max_value}). The cells are divided vertically to fractions specifies by the \code{digits} argument.
#' @return Returns a \link[ggplot2]{ggplot2} waffle plot
#' @import ggplot2 dplyr
#' @family waffle
#' @author Mikko Vihtakari with code ideas from \href{https://github.com/hrbrmstr/waffle}{hrbrmstr} and \href{https://github.com/liamgilbey/ggwaffle}{Liam Gilbey}
#' @export
# data = dt; fill = "variable"; value = "value"; facet = NULL; composition = TRUE; max_value = NULL; digits = 3; fill_colors = NULL; fill_title = NULL; ncol = NULL; base_size = 12; legend.position = "bottom"
waffle_chart <- function(data, fill, value = "value", facet = NULL, composition = TRUE, max_value = NULL, digits = 3, fill_colors = NULL, fill_title = NULL, ncol = NULL, base_size = 12, legend.position = "bottom") {
## White 1% grid
grid_data <- data.frame(xmin = c(0,(1:9)*10^(digits-2)), xmax = (1:10)*10^(digits-2), ymin = rep(c(0,(1:9)*10^(digits-2)), each = 10^(digits-2)), ymax = rep((1:10)*10^(digits-2), each = 10^(digits-2)))
if(is.null(facet)) { ## No facetting
if(any(duplicated(data[[fill]]))) stop("data contains duplicated entries in fill column. Use the facet argument or summarize data before plotting.")
waffle_data <- waffleize(dt = data, fill = fill, value = value, composition = composition, max_value = max_value, digits = digits)
## Plot ####
p <- ggplot() +
geom_rect(data = waffle_data, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = variable)) +
geom_rect(data = grid_data, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax), fill = NA, color = "white") +
coord_equal(expand = FALSE) +
theme_void()
## ####
} else { ## Facetting
waffle_data <- data %>% group_by_(facet) %>% do(waffleize(dt = ., fill = fill, value = value, composition = composition, max_value = max_value, digits = digits))
## Plot ####
p <- ggplot() +
geom_rect(data = waffle_data, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax, fill = variable)) +
geom_rect(data = grid_data, aes(xmin = xmin, xmax = xmax, ymin = ymin, ymax = ymax), fill = NA, color = "white") +
facet_wrap(facet, ncol = ncol) +
coord_equal(expand = FALSE) +
theme_void()
## ####
}
## Fill colors ####
if(is.null(fill_title)) fill_title <- "Variable"
if(!is.null(fill_colors)) {
p <- p + scale_fill_manual(name = fill_title, values = fill_colors)
} else {
p <- p + scale_fill_viridis_d(name = fill_title)
}
## Final theme manipulation
p <- p + theme(
legend.position = legend.position,
aspect.ratio = 1,
panel.border = element_rect(color = "black", size = LS(1), fill = NA),
strip.background = element_rect(fill = alpha("white", 0.4), color = NA),
strip.text.x = element_text(size = base_size*0.8, margin = margin(t = 2, r = 0, b = 3, l = 0, unit = "pt")),
plot.title = element_text(size = base_size, hjust = 0.5, face = 2),
legend.background = element_blank(),
legend.box.background = element_blank(),
legend.title = element_text(size = base_size),
legend.text = element_text(size = base_size),
plot.background = element_blank(),
panel.spacing = unit(0.2, units = "line"),
legend.box.margin = margin(t = 0, r = 0, b = 3, l = 0, unit = "pt"),
plot.margin = unit(c(0.2, 0.5, 0.1, 0.1), units = "line")
)
## Return the plot
p
}
终于可以制作图表了：
# Manipulate the dataset first to make sure that there are no replicate
# entries of factors used for the waffles
data("mtcars")
mtcars$gear_vs <- paste(mtcars$gear, mtcars$vs, sep = "-")
mtcars$carb <- factor(mtcars$carb)
x <- mtcars %>% group_by(gear_vs, carb) %>% summarise(value = sum(hp))
waffle_chart(x, fill = "carb", facet = "gear_vs", value = "value")
## You can also scale the waffles to a maximum hp in gear_vs
y <- x %>% group_by(gear_vs) %>% summarise(value = sum(value))
waffle_chart(x, fill = "carb", facet = "gear_vs", value = "value", composition = FALSE, max_value = max(y$value))
这是另一种方法，仅使用 tidyverse（即 dplyr、tidyr 和 ggplot2）来创建 华夫饼图 或 方形饼图 。它基于
library(tidyverse)
freq_table = mtcars %>%
count(gear, vs, carb, wt = hp) %>%
group_by(gear, vs) %>%
mutate(pct = n / sum(n)) %>%
select(gear, vs, carb, pct)
第二步创建坐标。使用 tidyr::expand() 而不是 waffleize()。仍在使用 smart_round().
waffle.n = 100 # Number of blocks
waffle.cols = ceiling(sqrt(waffle.n)) # For square. Otherwise pick integer.
coordinates = freq_table %>%
group_by(gear, vs) %>%
mutate(waffle.num = smart_round(pct,1) * waffle.n) %>%
group_by(carb, gear, vs) %>%
expand(count = seq(1:waffle.num)) %>%
select(-count) %>%
group_by(gear, vs) %>%
arrange(gear, vs) %>%
mutate(
waffle.x = rep_len(1:waffle.cols, waffle.n),
waffle.y = floor((row_number() - 1) / waffle.cols)
)
我按两个变量（gear 和 vs）分组，因此使用 facet_grid()。如果您按单个变量分组，则使用 facet_wrap()。您需要稍微调整选项以获得最佳结果（例如设备的大小，或点的大小和笔划）。
fig = coordinates %>%
ggplot(aes(x = waffle.x, y = waffle.y, fill = as.factor(carb))) +
geom_point(size = 7, shape = 22, color = "white", stroke = 0.8) +
#geom_raster() + # Alternative to geom_point() without gap between blocks.
facet_grid(rows = vars(gear), cols = vars(vs)) +
theme_void() +
theme(legend.position = "bottom", plot.margin = margin(5.5, 5.5, 5.5, 5.5, "pt"), panel.spacing = unit(15, "pt"))
fig
#ggsave("fig.pdf", width = 13, height = 17.5, units = "cm", dpi = 150)
A more interesting example块数不均匀且份额不能被10整除。