rchartswaffle-chart
How to show groups with values < 1 on waffle chart legend
I am trying to have the waffle plot made from the hrbrmstr/waffle package show the group square in the legend even for groups that have values smaller than 1. However, I am not able to make it work.
I am using the following Stackoverflow solutions to troubleshoot this problem below: Waffle plot does not show one group
# remotes::install_github("hrbrmstr/waffle")
library(waffle)
df <- structure(list(Category = c(
"Group1", "Group2", "Group3",
"Group4", "Group5", "Group6"),
Percentage = c(50.31, 39.95,
6.21, 3.10, 0.41, 0)),
row.names = c(NA, -6L), class = "data.frame")
# Problem is the last two groups have no colour on the legend
waffle::waffle(df)
# Try to add them manually, but doesn't work
waffle::waffle(df, colors = c(RColorBrewer::brewer.pal(nrow(df), "Set2")))
# If we add one more colour, then we get a weird filling, which I don't want
waffle::waffle(df, colors = c(RColorBrewer::brewer.pal(nrow(df) + 1, "Set2")))
# We try with scale_fill_manual, but we get an error
waffle::waffle(df) +
ggplot2::scale_fill_manual(
values = c(RColorBrewer::brewer.pal(nrow(df), "Set2")),
drop = FALSE)
#> Scale for fill is already present.
#> Adding another scale for fill, which will replace the existing scale.
#> Error in `palette()`:
#> ! Insufficient values in manual scale. 7 needed but only 6 provided.
# We add +1 to make it work, but it solves none of our problems :/
waffle::waffle(df) +
ggplot2::scale_fill_manual(
values = c(RColorBrewer::brewer.pal(nrow(df) + 1, "Set2")),
drop = FALSE)
#> Scale for fill is already present.
#> Adding another scale for fill, which will replace the existing scale.
# We try with a vector instead of a data frame but same thing...
vec <- setNames(df$Percentage, df$Category)
waffle::waffle(vec)
waffle::waffle(vec, colors = c(RColorBrewer::brewer.pal(nrow(df) + 1, "Set2")))
waffle::waffle(vec) +
ggplot2::scale_fill_manual(
values = c(RColorBrewer::brewer.pal(nrow(df) + 1, "Set2")),
drop = FALSE)
#> Scale for fill is already present.
#> Adding another scale for fill, which will replace the existing scale.
Created on 2024-05-17 with reprex v2.1.0
Note that I also do not want to use the ceiling() solution because (1) the total will go over 100%, and (2) this will misrepresent the data if it is 0.00001%.
Solution
I don't think this can be done without some alterations to the waffle code. You might consider submitting a feature request, but incorporating groups with values < 1 introduces some design questions without (it seems to me) satisfactory answers.
I command-clicked on waffle::waffle to get its source code. I made a modified version with this addition just below if (inherits(use_glyph, "logical")) {
gg <- gg + geom_tile(aes(fill = value), color = "white", size = size,
data = data.frame(x = 1, y = 1,
value = part_names))
This will make a layer underneath the main one, which gets covered by the main one but still generates the desired legend:
Here's that code (based on waffle 1.0.2), not guaranteed to work in any other situations!
waffle2 <- function (parts, rows = 10, keep = TRUE, xlab = NULL, title = NULL,
colors = NA, size = 2, flip = FALSE, reverse = FALSE, equal = TRUE,
pad = 0, use_glyph = FALSE, glyph_size = 12, glyph_font = "Font Awesome 5 Free Solid",
glyph_font_family = "FontAwesome5Free-Solid", legend_pos = "right")
{
if (inherits(parts, "data.frame")) {
parts <- stats::setNames(unlist(parts[, 2], use.names = FALSE),
unlist(parts[, 1], use.names = FALSE))
}
part_names <- names(parts)
if (length(part_names) < length(parts)) {
part_names <- c(part_names, LETTERS[1:length(parts) -
length(part_names)])
}
names(parts) <- part_names
if (all(is.na(colors)))
colors <- suppressWarnings(RColorBrewer::brewer.pal(length(parts),
"Set2"))
parts_vec <- unlist(sapply(1:length(parts), function(i) {
rep(names(parts)[i], parts[i])
}))
if (reverse)
parts_vec <- rev(parts_vec)
dat <- expand.grid(y = 1:rows, x = seq_len(pad + (ceiling(sum(parts)/rows))))
dat$value <- c(parts_vec, rep(NA, nrow(dat) - length(parts_vec)))
if (!inherits(use_glyph, "logical")) {
if (length(use_glyph) == 1L) {
if (grepl("wesom", glyph_font)) {
fontlab <- .fa_unicode[.fa_unicode[["name"]] ==
use_glyph, "unicode"]
dat$fontlab <- c(rep(fontlab, length(parts_vec)),
rep("", nrow(dat) - length(parts_vec)))
}
else {
dat$fontlab <- c(rep(use_glyph, length(parts_vec)),
rep("", nrow(dat) - length(parts_vec)))
}
}
else if (length(use_glyph) == length(parts)) {
if (grepl("wesom", glyph_font)) {
fontlab <- .fa_unicode[.fa_unicode[["name"]] %in%
use_glyph, "unicode"]
dat$fontlab <- c(fontlab[as.numeric(factor(parts_vec,
levels = names(parts)))], rep("", nrow(dat) -
length(parts_vec)))
}
else {
dat$fontlab <- c(use_glyph[as.numeric(factor(parts_vec,
levels = names(parts)))], rep("", nrow(dat) -
length(parts_vec)))
}
}
else if (length(use_glyph) == length(parts_vec)) {
if (grepl("wesom", glyph_font)) {
fontlab <- .fa_unicode[.fa_unicode[["name"]] %in%
use_glyph, "unicode"]
dat$fontlab <- c(fontlab, rep(NA, nrow(dat) -
length(parts_vec)))
}
else {
dat$fontlab <- c(use_glyph, rep(NA, nrow(dat) -
length(parts_vec)))
}
}
else {
stop("'use_glyph' must have length 1, length(parts), or sum(parts)")
}
}
dat$value <- ifelse(is.na(dat$value), " ", dat$value)
if (" " %in% dat$value)
part_names <- c(part_names, " ")
if (" " %in% dat$value)
colors <- c(colors, "#00000000")
dat$value <- factor(dat$value, levels = part_names)
gg <- ggplot(dat, aes(x = x, y = y))
if (flip)
gg <- ggplot(dat, aes(x = y, y = x))
gg <- gg + theme_bw()
if (inherits(use_glyph, "logical")) {
gg <- gg + geom_tile(aes(fill = value), color = "white", ## ADDED BIT
size = size, ## ADDED BIT
data = data.frame(x = 1, y = 1, ## ADDED BIT
value = part_names)) ## ADDED BIT
gg <- gg + geom_tile(aes(fill = value), color = "white",
size = size)
gg <- gg + scale_fill_manual(name = "", values = colors,
label = part_names, na.value = "white", drop = !keep)
gg <- gg + guides(fill = guide_legend(override.aes = list(colour = "#00000000")))
gg <- gg + theme(legend.background = element_rect(fill = "#00000000",
color = "#00000000"))
gg <- gg + theme(legend.key = element_rect(fill = "#00000000",
color = "#00000000"))
}
else {
if (extrafont::choose_font(glyph_font, quiet = TRUE) ==
"") {
stop(sprintf("Font [%s] not found. Please install it and use extrafont to make it available to R",
glyph_font), call. = FALSE)
}
load_fontawesome()
gg <- gg + geom_tile(color = "#00000000", fill = "#00000000",
size = size, alpha = 0, show.legend = FALSE)
gg <- gg + geom_point(aes(color = value), fill = "#00000000",
size = 0, show.legend = TRUE)
gg <- gg + geom_text(aes(color = value, label = fontlab),
family = glyph_font_family, size = glyph_size, show.legend = FALSE)
gg <- gg + scale_color_manual(name = NULL, values = colors,
labels = part_names, drop = !keep)
gg <- gg + guides(color = guide_legend(override.aes = list(shape = 15,
size = 7)))
gg <- gg + theme(legend.background = element_rect(fill = "#00000000",
color = "#00000000"))
gg <- gg + theme(legend.key = element_rect(color = "#00000000"))
}
gg <- gg + labs(x = xlab, y = NULL, title = title)
gg <- gg + scale_x_continuous(expand = c(0, 0))
gg <- gg + scale_y_continuous(expand = c(0, 0))
if (equal)
gg <- gg + coord_equal()
gg <- gg + theme(panel.grid = element_blank())
gg <- gg + theme(panel.border = element_blank())
gg <- gg + theme(panel.background = element_blank())
gg <- gg + theme(panel.spacing = unit(0, "null"))
gg <- gg + theme(axis.text = element_blank())
gg <- gg + theme(axis.title.x = element_text(size = 10))
gg <- gg + theme(axis.ticks = element_blank())
gg <- gg + theme(axis.line = element_blank())
gg <- gg + theme(axis.ticks.length = unit(0, "null"))
gg <- gg + theme(plot.title = element_text(size = 18))
gg <- gg + theme(plot.background = element_blank())
gg <- gg + theme(panel.spacing = unit(c(0, 0, 0, 0), "null"))
gg <- gg + theme(legend.position = legend_pos)
gg
}
- Determining as to whether the function call is stored in a variable
- How to increase resolution of ggplots without using ggsave in officer?
- How to apply a function within a for loop for a set of existing variables of a predifined structure in R?
- How to change the number of decimal places of the mean in a data frame
- Forestplot in R superscript in tabletext matrix
- Converting colnames from character to numeric when extracting them from a dataframe
- With different seeds can Random States repeat in R
- How to Stack Painted Phylogenetic Trees in R Like ggdensitree but with Colored Regimes
- How to import/rbind multiple files with different indexed columns?
- Pivot wider in R return list instead of data frame
- R workspace doesn't load anything in Visual Studio Code
- Search for multiple occurrences of substring within string
- Looking for faster way to implement logSumExp across multidimensional array
- How to get \bm{} to work in an R markdown (to HTML) file?
- Leaving a space in geom_bar with stat='bin', position='dodge' and zeroes
- Where are the 1st stage F statistics located in a "fixest" object?
- Collapsing data per family
- How to set default template for new ".R" files in rstudio
- Adding two-way fixed effects for zero inflated Poisson model
- How to Move R Code and Output to the Right in a Quarto PDF Document?
- What does runif() mean when used inside if_else()?
- Remove columns from dataframe where ALL values are NA
- How to pass unquoted argument to filter() within user defined function
- Optimizing the distribution of random integers across data frame rows
- R dplyr conditional join with "join_by" not working
- How to hide a reappearing hover label for a trace in R-Plotly within Shiny?
- Estimating non-monotonic bi-exponential curve fit
- Problem minimising a function using L-BFGS-B method in R?
- trying to obtain TRUE/FALSE response to the question "is argument name x valid for function y?"
- Retrieve whole lyrics from URL