a ggplot2 layer tabulation demonstration
Evangeline Reynolds
2024-07-02
Save information about the entire data set (not panel-wise) in compute_layer_prop.
Seems
library(tidyverse)
compute_layer_prop <- function(data = mtcars, ...){
if(is.null(data$value)){data$value <- 1}
global_sum <- sum(data$value)
data %>%
group_by(PANEL) %>%
summarize(sum = sum(value)) %>%
mutate(prop = sum/global_sum) %>%
mutate(label = round(100 * prop, 1) %>% paste0("%")) %>%
mutate(x = 0, y = 0)
}
Titanic %>%
data.frame() %>%
uncount(Freq) %>%
group_by(Sex, Survived) %>%
mutate(cell = paste(Sex, Survived, sep = "-")) %>%
mutate(PANEL = paste(as.numeric(Sex), as.numeric(Survived), sep = "-")) %>%
compute_layer_prop()## Warning: Unknown or uninitialised column: `value`.## # A tibble: 4 × 6
## PANEL sum prop label x y
## <chr> <dbl> <dbl> <chr> <dbl> <dbl>
## 1 1-1 1364 0.620 62% 0 0
## 2 1-2 367 0.167 16.7% 0 0
## 3 2-1 126 0.0572 5.7% 0 0
## 4 2-2 344 0.156 15.6% 0 0StatProp <- ggproto(`_class` = "StatProp",
`_inherit` = Stat,
compute_layer = compute_layer_prop)
Titanic %>%
data.frame() %>%
uncount(Freq) %>%
ggplot(aes(fill = after_stat(prop))) +
facet_grid(Sex ~ Survived) +
layer(geom = "tile",
stat = StatProp,
position = "identity") +
layer(geom = "text",
stat = StatProp,
position = "identity")
layer_data()## fill PANEL sum prop label x y xmin xmax ymin ymax colour linewidth
## 1 #56B1F7 1 1364 0.61971831 62% 0 0 -0.5 0.5 -0.5 0.5 NA 0.1
## 2 #1F4263 2 367 0.16674239 16.7% 0 0 -0.5 0.5 -0.5 0.5 NA 0.1
## 3 #132B43 3 126 0.05724671 5.7% 0 0 -0.5 0.5 -0.5 0.5 NA 0.1
## 4 #1E4060 4 344 0.15629259 15.6% 0 0 -0.5 0.5 -0.5 0.5 NA 0.1
## linetype alpha width height
## 1 1 NA NA NA
## 2 1 NA NA NA
## 3 1 NA NA NA
## 4 1 NA NA NAlibrary(tidyverse)
Titanic %>%
data.frame() %>%
uncount(Freq) ->
tidy_titanic
compute_layer_prop_by <- function(data = tidy_titanic, ...){
if(is.null(data$value)){data$value <- 1}
if(is.null(data$prop_by)){data$prop_by <- 1}
if(is.null(data$wt)){data$wt <- 1}
data$value <- data$value * data$wt
data %>%
group_by(prop_by) %>%
summarize(group_sum = sum(.data$value)) ->
group_sum_df
data %>%
left_join(group_sum_df, by = "prop_by") %>%
group_by(PANEL, prop_by) %>%
summarize(sum = sum(.data$value),
group_sum = mean(.data$group_sum)) %>%
mutate(prop = sum/group_sum) %>%
mutate(prop_label = round(prop, 3)) %>%
mutate(percent_label = paste0(prop_label * 100, "%")) %>%
mutate(count_percent_label = paste0(sum, "\n(", percent_label, ")" )) %>%
mutate(percent_count_label = paste0(percent_label, "\n(", sum, ")" )) %>%
mutate(x = 0, y = 0)
}
aes_label_count_percent <- function(){
aes(label = after_stat(paste0(sum, "\n(", percent_label, ")" )))
}
aes_label_percent_count <- function(){
aes(label = after_stat(paste0(percent_label, "\n(", sum, ")" )))
}
# test compute layer
tidy_titanic %>%
mutate(prop_by = Sex) %>%
mutate(PANEL = paste(as.numeric(Sex),
as.numeric(Survived), sep = "-")) %>%
ungroup() %>%
compute_layer_prop_by()## `summarise()` has grouped output by 'PANEL'. You can override using the
## `.groups` argument.## # A tibble: 4 × 11
## # Groups: PANEL [4]
## PANEL prop_by sum group_sum prop prop_label percent_label
## <chr> <fct> <dbl> <dbl> <dbl> <dbl> <chr>
## 1 1-1 Male 1364 1731 0.788 0.788 78.8%
## 2 1-2 Male 367 1731 0.212 0.212 21.2%
## 3 2-1 Female 126 470 0.268 0.268 26.8%
## 4 2-2 Female 344 470 0.732 0.732 73.2%
## # ℹ 4 more variables: count_percent_label <chr>, percent_count_label <chr>,
## # x <dbl>, y <dbl>StatPropby <- ggproto(`_class` = "StatPropby",
`_inherit` = Stat,
compute_layer = compute_layer_prop_by,
default_aes = aes(label = after_stat(sum),
fill = after_stat(prop_by)))
stat_tableprop <- function(geom = "text"){
layer(geom = geom,
stat = StatPropby,
position = "identity",
params = list(size = 8, color = "whitesmoke"))
}
and <- paste # not super careful category combostidy_titanic %>%
ggplot() +
theme(axis.text = element_blank(),
axis.ticks = element_blank(),
panel.grid = element_blank(),
text = element_text(size = 22)) +
guides(fill = "none") +
stat_tableprop(geom = "tile") +
stat_tableprop() +
facet_grid(~ Sex) + # specify table layout
facet_grid(Sex ~ Survived) +
aes(label = after_stat(prop_label)) +
aes(label = after_stat(percent_label)) +
aes(prop_by = Sex) +
aes(label = after_stat(count_percent_label)) +
aes(label = after_stat(percent_count_label)) +
facet_grid(rows = vars(Sex),
cols = vars(Age, Survived)) +
aes(prop_by = Sex) +
aes(prop_by = Age) +
facet_grid(rows = vars(Age)) +
aes(prop_by = NULL) +
aes(label = after_stat(sum))## Warning: Using `size` aesthetic for lines was deprecated in ggplot2 3.4.0.
## ℹ Please use `linewidth` instead.
## This warning is displayed once every 8 hours.
## Call `lifecycle::last_lifecycle_warnings()` to see where this warning was
## generated.## `summarise()` has grouped output by 'PANEL'. You can override using the
## `.groups` argument.
## `summarise()` has grouped output by 'PANEL'. You can override using the
## `.groups` argument.
layer_data()## `summarise()` has grouped output by 'PANEL'. You can override using the
## `.groups` argument.
## `summarise()` has grouped output by 'PANEL'. You can override using the
## `.groups` argument.## fill label PANEL prop_by sum group_sum prop prop_label
## 1 #336A98 109 1 1 109 2201 0.04952294 0.05
## 2 #336A98 2092 2 1 2092 2201 0.95047706 0.95
## percent_label count_percent_label percent_count_label x y xmin xmax ymin ymax
## 1 5% 109\n(5%) 5%\n(109) 0 0 -0.5 0.5 -0.5 0.5
## 2 95% 2092\n(95%) 95%\n(2092) 0 0 -0.5 0.5 -0.5 0.5
## colour linewidth linetype alpha width height
## 1 whitesmoke 8 1 NA NA NA
## 2 whitesmoke 8 1 NA NA NAknitr::knit_exit()