library(tidyverse)
original_dat <- tribble(
~cat, ~group, ~strongly_oppose, ~somewhat_oppose, ~somewhat_favor, ~strongly_favor, ~neither, ~no_experience,
'High school or less', 'education', 23, 16, 13, 9, 32, 7,
'Some college', 'education', 21, 18, 15, 9, 35, 2,
'Bachelor\'s degree', 'education', 20, 20, 20, 8, 31, 1,
'Postgraduate', 'education', 23, 19, 20, 8, 30, 1,
)
## # A tibble: 14 ×
dat_longer <- original_dat |>
pivot_longer(
cols = strongly_oppose:no_experience,
values_to = 'percentage',
names_to = 'response'
)
dat_diverging <- dat_longer |>
filter(!(response %in% c('neither', 'no_experience')))
computed_values <- dat_diverging |>
mutate(
middle_shift = sum(percentage[1:2]),
lagged_percentage = lag(percentage, default = 0),
left = cumsum(lagged_percentage) - middle_shift,
right = cumsum(percentage) - middle_shift,
middle_point = (left + right) / 2,
width = right - left,
.by = cat
)
computed_values
## # A tibble: 16 × 10
## cat group response percentage middle_shift lagged_percentage left right
## <chr> <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 High sc… educ… strongl… 23 39 0 -39 -16
## 2 High sc… educ… somewha… 16 39 23 -16 0
## 3 High sc… educ… somewha… 13 39 16 0 13
## 4 High sc… educ… strongl… 9 39 13 13 22
## 5 Some co… educ… strongl… 21 39 0 -39 -18
## 6 Some co… educ… somewha… 18 39 21 -18 0
## 7 Some co… educ… somewha… 15 39 18 0 15
## 8 Some co… educ… strongl… 9 39 15 15 24
## 9 Bachelo… educ… strongl… 20 40 0 -40 -20
## 10 Bachelo… educ… somewha… 20 40 20 -20 0
## 11 Bachelo… educ… somewha… 20 40 20 0 20
## 12 Bachelo… educ… strongl… 8 40 20 20 28
## 13 Postgra… educ… strongl… 23 42 0 -42 -19
## 14 Postgra… educ… somewha… 19 42 23 -19 0
## 15 Postgra… educ… somewha… 20 42 19 0 20
## 16 Postgra… educ… strongl… 8 42 20 20 28
## # ℹ 2 more variables: middle_point <dbl>, width <dbl>
bar_width <- 0.75
computed_values |>
ggplot() +
geom_tile(
aes(
x = middle_point,
y = cat,
width = width,
fill = response
),
height = bar_width
)
Experiment: Stat Experiment… geom_tile(StatDivergent)
library(tidyverse)
original_dat <- tribble(
~cat, ~group, ~strongly_oppose, ~somewhat_oppose, ~somewhat_favor, ~strongly_favor, ~neither, ~no_experience,
'High school or less', 'education', 23, 16, 13, 9, 32, 7,
'Some college', 'education', 21, 18, 15, 9, 35, 2,
'Bachelor\'s degree', 'education', 20, 20, 20, 8, 31, 1,
'Postgraduate', 'education', 23, 19, 20, 8, 30, 1,
)
## # A tibble: 14 ×
dat_longer <- original_dat |>
pivot_longer(
cols = strongly_oppose:no_experience,
values_to = 'percentage',
names_to = 'response'
)
dat_diverging <- dat_longer |>
filter(!(response %in% c('neither', 'no_experience')))
compute_panel_likert <- function(data, scales){
data |>
mutate(
middle_shift = sum(x[1:2]),
lagged_percentage = lag(x, default = 0),
left = cumsum(lagged_percentage) - middle_shift,
right = cumsum(x) - middle_shift,
x = (left + right) / 2,
width = right - left,
.by = y
)
}
dat_diverging %>%
select(x = percentage,
y = cat,
color = response) %>%
compute_panel_likert()
## # A tibble: 16 × 8
## x y color middle_shift lagged_percentage left right width
## <dbl> <chr> <chr> <dbl> <dbl> <dbl> <dbl> <dbl>
## 1 -27.5 High school or … stro… 39 0 -39 -16 23
## 2 -8 High school or … some… 39 23 -16 0 16
## 3 6.5 High school or … some… 39 16 0 13 13
## 4 17.5 High school or … stro… 39 13 13 22 9
## 5 -28.5 Some college stro… 39 0 -39 -18 21
## 6 -9 Some college some… 39 21 -18 0 18
## 7 7.5 Some college some… 39 18 0 15 15
## 8 19.5 Some college stro… 39 15 15 24 9
## 9 -30 Bachelor's degr… stro… 40 0 -40 -20 20
## 10 -10 Bachelor's degr… some… 40 20 -20 0 20
## 11 10 Bachelor's degr… some… 40 20 0 20 20
## 12 24 Bachelor's degr… stro… 40 20 20 28 8
## 13 -30.5 Postgraduate stro… 42 0 -42 -19 23
## 14 -9.5 Postgraduate some… 42 23 -19 0 19
## 15 10 Postgraduate some… 42 19 0 20 20
## 16 24 Postgraduate stro… 42 20 20 28 8
StatDivergent <- ggproto("StatDivergent",
Stat,
compute_panel = compute_panel_likert)
dat_diverging |>
ggplot() +
aes(x = percentage,
y = cat,
fill = response) +
geom_tile(stat = StatDivergent, height = .75)
last_plot() +
aes(fill = NULL)
last_plot() +
aes(alpha = response)
## Warning: Using alpha for a discrete variable is not advised.
last_plot() +
aes(color = response) +
aes(linewidth = I(.5))
## Warning: Using alpha for a discrete variable is not advised.
w/ ggstats::position_likert()
dat_diverging |>
ggplot() +
aes(y = cat) +
aes(weight = percentage) +
aes(fill = response) +
geom_bar() +
labs(tag = 1)
last_plot() +
aes(fill = response %>%
fct_inorder()) +
labs(tag = 2)
ggwipe::last_plot_wipe() +
geom_bar(position =
ggstats::position_likert()) +
labs(tag = 3)
custom_label <- function(x) {
p <- scales::percent(x, accuracy = 1)
p[x < .075] <- ""
p
}
last_plot() +
geom_text(
aes(by = as.factor(cat),
label = custom_label(after_stat(prop))),
stat = ggstats::StatProp,
position = ggstats::position_likert(vjust = .5)
) +
scale_x_continuous(label = ggstats::label_percent_abs()) +
labs(tag = 4)
library(ggstats)
library(tidyverse)
age_cats <- c("18-29", "30-49"," 50-64", "65+")
sex_cats <- c("Male", "Female")
edu_cats <- c('High school or less', "Some college", "Bachelor's Degree",
"Postgraduate")
income_cats <- c("Lower Income", "Middle Income", "Upper Income")
likert_cats <- c("strongly oppose", "somewhat_oppose", "neither",
"somewhat_favor", "strongly_favor")
likertforce_cats <- c("strongly oppose", "somewhat_oppose",
"somewhat_favor", "strongly_favor")
sample40replaceT <- function(x){
sample(x, size = 40, replace = T) %>% factor(levels = x)
}
survey <- data.frame(c1 = sample40replaceT(age_cats),
c2 = sample40replaceT(sex_cats),
c3 = sample40replaceT(edu_cats),
c4 = sample40replaceT(income_cats),
q1 = sample40replaceT(likert_cats),
q2 = sample40replaceT(likert_cats),
q3 = sample40replaceT(likert_cats),
q4 = sample40replaceT(likertforce_cats))
survey |> head()
## c1 c2 c3 c4 q1
## 1 18-29 Male High school or less Lower Income strongly_favor
## 2 50-64 Male High school or less Middle Income somewhat_favor
## 3 30-49 Male Bachelor's Degree Upper Income strongly oppose
## 4 50-64 Male High school or less Middle Income strongly_favor
## 5 18-29 Female Bachelor's Degree Lower Income somewhat_favor
## 6 65+ Male Some college Upper Income strongly oppose
## q2 q3 q4
## 1 somewhat_oppose strongly_favor somewhat_oppose
## 2 strongly_favor strongly oppose strongly_favor
## 3 strongly oppose strongly oppose somewhat_oppose
## 4 somewhat_favor somewhat_oppose somewhat_favor
## 5 strongly_favor strongly_favor somewhat_oppose
## 6 neither strongly_favor somewhat_oppose
# using ggstats guidance on position_likert()
library(ggstats)
survey %>%
ggplot() +
aes(y = c1, fill = q1) +
geom_bar(position = ggstats::position_likert(vjust = .5),
stat = ggstats::StatProp,
complete = "fill")
custom_label <- function(x) {
p <- scales::percent(x, accuracy = 1)
p[x < .075] <- ""
p
}
last_plot() +
aes(by = c1, label = custom_label(after_stat(prop))) +
geom_text(
stat = ggstats::StatProp,
position = ggstats::position_likert(vjust = .5),
complete = "fill"
) +
scale_x_continuous(label = label_percent_abs())
geom_likert <- function (mapping = NULL, data = NULL, stat = StatProp, position = ggstats::position_likert(vjust = .5),
..., just = 0.5, width = NULL, na.rm = FALSE, orientation = NA,
show.legend = NA, inherit.aes = TRUE)
{
layer(data = data, mapping = mapping, stat = stat, geom = GeomBar,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = rlang::list2(just = just, width = width, na.rm = na.rm,
orientation = orientation, complete = "fill", ...))
}
geom_likert_text <- function (mapping = NULL, data = NULL,
stat = StatProp,
position = ggstats::position_likert(vjust = .5),
..., parse = FALSE, nudge_x = 0, nudge_y = 0, check_overlap = FALSE,
size.unit = "mm", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE)
{
if (!missing(nudge_x) || !missing(nudge_y)) {
if (!missing(position)) {
cli::cli_abort(c("Both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied.",
i = "Only use one approach to alter the position."))
}
position <- position_nudge(nudge_x, nudge_y)
}
layer(data = data, mapping = mapping, stat = stat, geom = GeomText,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = rlang::list2(parse = parse, check_overlap = check_overlap,
size.unit = size.unit, na.rm = na.rm, complete = "fill", ...))
}
survey %>%
ggplot() +
aes(y = c1, fill = q1) +
geom_likert() +
aes(label = custom_label(after_stat(prop))) +
geom_likert_text(aes(by = c1))
StatProptext <- ggproto("StatProptext",
ggstats::StatProp)
StatProptext$default_aes <- aes(#by = after_stat(y),
label = custom_label(after_stat(prop)))
geom_likert_text <- function (mapping = NULL, data = NULL,
stat = StatProptext,
position = ggstats::position_likert(vjust = .5),
..., parse = FALSE, nudge_x = 0, nudge_y = 0, check_overlap = FALSE,
size.unit = "mm", na.rm = FALSE, show.legend = NA, inherit.aes = TRUE)
{
if (!missing(nudge_x) || !missing(nudge_y)) {
if (!missing(position)) {
cli::cli_abort(c("Both {.arg position} and {.arg nudge_x}/{.arg nudge_y} are supplied.",
i = "Only use one approach to alter the position."))
}
position <- position_nudge(nudge_x, nudge_y)
}
layer(data = data, mapping = mapping, stat = stat, geom = GeomText,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = rlang::list2(parse = parse, check_overlap = check_overlap,
size.unit = size.unit, na.rm = na.rm, complete = "fill", ...))
}
survey %>%
ggplot() +
aes(y = c1, fill = q1) +
geom_likert() +
aes(label = custom_label(after_stat(prop))) +
geom_likert_text(aes(by = c1))
## Warning in geom_likert_text(aes(by = c1)): Ignoring unknown aesthetics: by
## Error in `geom_likert_text()`:
## ! Problem while setting up geom.
## ℹ Error occurred in the 2nd layer.
## Caused by error in `compute_geom_1()`:
## ! `geom_text()` requires the following missing aesthetics: x.
library(tidyverse)
age_cats <- c("18-29", "30-49"," 50-64", "65+")
sex_cats <- c("Male", "Female")
sample40replaceT <- function(x){
sample(x, size = 40, replace = T) %>% factor(levels = x)
}
survey <- data.frame(c1 = sample40replaceT(age_cats),
c2 = sample40replaceT(sex_cats))
survey %>%
ggplot() +
aes(y = c1, fill = c2) +
geom_bar(position = ggstats::position_likert_count())
# drop shadow layer (if MF counts were equal) attempt
last_plot() +
aes(fill = NULL)
# drop shadow layer attempt 2
last_plot() +
aes(fill = "All")
