349 lines
12 KiB
R
349 lines
12 KiB
R
```{r}
|
|
|
|
# Load some new libraries used by functions below
|
|
|
|
library(RColorBrewer)
|
|
library(hrbrthemes) # Used for ipsum theme etc.
|
|
library(ggeasy) # used for easy_center_title() which is not strictly necessary, but tidier than theme(plot.title = element_text(hjust = 0.5))
|
|
|
|
# Define colour palettes
|
|
# TODO: confirm final colour scheme for charts and normalise across usage of different themes
|
|
coul3 <- brewer.pal(3, "RdYlBu") # Using RdYlBu range to generate 3 colour palette: https://colorbrewer2.org/#type=diverging&scheme=RdYlBu&n=5
|
|
coul4 <- brewer.pal(4, "RdYlBu")
|
|
coul5 <- brewer.pal(5, "RdYlBu")
|
|
coul6 <- brewer.pal(6, "RdYlBu")
|
|
coul7 <- brewer.pal(7, "RdYlBu")
|
|
coul4_reversed <- c("#2C7BB6", "#ABD9E9", "#FDAE61", "#D7191C")
|
|
coul6_reversed <- c("#4575B4", "#91BFDB" , "#E0F3F8" , "#FEE090", "#FC8D59", "#D73027")
|
|
white <- "#ffffff"
|
|
purple <- "#590048"
|
|
ochre <- "#B18839"
|
|
ochre_12 <- wheel(ochre, num = 12)
|
|
purple_12 <- wheel(purple, num = 12)
|
|
|
|
# Reusable Functions ------------------------------------------------------
|
|
|
|
# Importing code for colortools() now deprecated and removed from CRAN here. Some minor modifications to update code, but generally all credit here goes to Gaston Sanchez
|
|
|
|
setColors <- function(color, num) {
|
|
# convert to RGB
|
|
rgb_col = col2rgb(color)
|
|
# convert to HSV
|
|
hsv_col = rgb2hsv(rgb_col)[,1]
|
|
# get degree
|
|
hue = hsv_col[1]
|
|
sat = hsv_col[2]
|
|
val = hsv_col[3]
|
|
cols = seq(hue, hue + 1, by=1/num)
|
|
cols = cols[1:num]
|
|
cols[cols > 1] <- cols[cols > 1] - 1
|
|
# get colors with hsv
|
|
colors = hsv(cols, sat, val)
|
|
# transparency
|
|
if (substr(color, 1, 1) == "#" && nchar(color) == 9)
|
|
({
|
|
alpha = substr(color, 8, 9)
|
|
colors = paste(colors, alpha, sep="")
|
|
})
|
|
colors
|
|
}
|
|
|
|
complementary <- function(color, plot=TRUE, bg="white", labcol=NULL, cex=0.8, title=TRUE) {
|
|
tmp_cols = setColors(color, 12)
|
|
comp_colors <- tmp_cols[c(1, 7)]
|
|
|
|
# plot
|
|
if (plot)
|
|
({
|
|
# labels color
|
|
if (is.null(labcol))
|
|
({
|
|
lab_col = rep("", 12)
|
|
if (mean(col2rgb(bg)) > 127)
|
|
({
|
|
lab_col[c(1, 7)] <- "black"
|
|
lab_col[c(2:6,8:12)] <- col2HSV(bg)
|
|
}) else ({
|
|
lab_col[c(1, 7)] <- "white"
|
|
lab_col[c(2:6,8:12)] <- col2HSV(bg)
|
|
})
|
|
}) else ({
|
|
lab_col = rep(labcol, 12)
|
|
if (mean(col2rgb(bg)) > 127)
|
|
({
|
|
lab_col[c(1, 7)] <- labcol
|
|
lab_col[c(2:6,8:12)] <- col2HSV(bg)
|
|
}) else ({
|
|
lab_col[c(1, 7)] <- labcol
|
|
lab_col[c(2:6,8:12)] <- col2HSV(bg)
|
|
})
|
|
})
|
|
# hide non-adjacent colors
|
|
tmp_cols[c(2:6,8:12)] <- paste(substr(tmp_cols[c(2:6,8:12)],1,7), "0D", sep="")
|
|
pizza(tmp_cols, labcol=lab_col, bg=bg, cex=cex)
|
|
# title
|
|
if (title)
|
|
title(paste("Complementary (opposite) color of: ", tmp_cols[1]),
|
|
col.main=lab_col[1], cex.main=0.8)
|
|
})
|
|
# result
|
|
comp_colors
|
|
}
|
|
|
|
sequential <- function(color, percentage=5, what="saturation", s=NULL, v=NULL, alpha=NULL, fun="linear", plot=TRUE, verbose=TRUE) {
|
|
# convert to HSV
|
|
col_hsv = rgb2hsv(col2rgb(color))[,1]
|
|
# transparency
|
|
if (is.null(alpha))
|
|
alpha = 1
|
|
if (substr(color, 1, 1) == "#" && nchar(color) == 9)
|
|
alpha = substr(color, 8, 9)
|
|
# get hue, saturation, and value
|
|
hue = col_hsv[1]
|
|
if (is.null(s)) s = col_hsv[2]
|
|
if (is.null(v)) v = col_hsv[3]
|
|
# sequence function
|
|
getseq = switch(fun,
|
|
linear = seq(0, 1, by=percentage/100),
|
|
sqrt = sqrt(seq(0, 1, by=percentage/100)),
|
|
log = log1p(seq(0, 1, by=percentage/100)),
|
|
log10 = log10(seq(0, 1, by=percentage/100))
|
|
)
|
|
# what type of sequence?
|
|
if (what == "saturation") ({
|
|
sat = getseq
|
|
fixed = paste("v=", round(v,2), " and alpha=", alpha, sep="")
|
|
if (is.numeric(alpha))
|
|
seq_col = hsv(hue, s=sat, v=v, alpha=alpha)
|
|
if (is.character(alpha)) ({
|
|
seq_col = hsv(hue, s=sat, v=v)
|
|
seq_col = paste(seq_col, alpha, sep="")
|
|
})
|
|
})
|
|
if (what == "value") ({
|
|
val = getseq
|
|
fixed = paste("s=", round(s,2), " and alpha=", alpha, sep="")
|
|
if (is.numeric(alpha))
|
|
seq_col = hsv(hue, s=s, v=val, alpha=alpha)
|
|
if (is.character(alpha)) ({
|
|
seq_col = hsv(hue, s=s, v=val)
|
|
seq_col = paste(seq_col, alpha, sep="")
|
|
})
|
|
})
|
|
if (what == "alpha") ({
|
|
alpha = getseq
|
|
fixed = paste("s=", round(s,2), " and v=", round(v,2), sep="")
|
|
seq_col = hsv(hue, s=s, v=v, alpha=alpha)
|
|
})
|
|
# if plot TRUE
|
|
if (plot)
|
|
({
|
|
n = length(seq(0, 1, by=percentage/100))
|
|
fx = unlist(fixed)
|
|
#dev.new()
|
|
plot(0, 0, type="n", xlim=c(0,1), ylim=c(0,1), axes=FALSE, xlab="", ylab="")
|
|
rect(0:(n-1)/n, 0, 1:n/n, 1, col=seq_col, border="lightgray")
|
|
mtext(seq_col, side=1, at=0.5:(n)/n, cex=0.8, las=2)
|
|
title(paste("Sequential colors based on ", what, "\n with fixed ", fx, sep=""),
|
|
cex.main=0.9)
|
|
})
|
|
# result
|
|
if (verbose)
|
|
seq_col
|
|
}
|
|
|
|
wheel <- function(color, num=12, bg="gray95", border=NULL, init.angle=105, cex=1, lty=NULL, main=NULL, verbose=TRUE, ...) {
|
|
if (!is.numeric(num) || any(is.na(num) | num < 0))
|
|
stop("\n'num' must be positive")
|
|
x <- rep(1, num)
|
|
x <- c(0, cumsum(x)/sum(x))
|
|
dx <- diff(x)
|
|
nx <- length(dx)
|
|
# set colors
|
|
col = setColors(color, num)
|
|
labels = col
|
|
# labels color
|
|
labcol = ifelse( mean(col2rgb(bg)) > 127, "black", "white")
|
|
# prepare plot window
|
|
par(bg = bg)
|
|
plot.new()
|
|
pin <- par("pin")
|
|
xlim <- ylim <- c(-1, 1)
|
|
if (pin[1L] > pin[2L])
|
|
xlim <- (pin[1L]/pin[2L]) * xlim
|
|
else ylim <- (pin[2L]/pin[1L]) * ylim
|
|
dev.hold()
|
|
on.exit(dev.flush())
|
|
plot.window(xlim, ylim, "", asp = 1)
|
|
# get ready to plot
|
|
if (is.null(border[1])) ({
|
|
border <- rep(bg, length.out = nx)
|
|
}) else ({
|
|
border <- rep(border, length.out = nx)
|
|
})
|
|
if (!is.null(lty))
|
|
lty <- rep(NULL, length.out = nx)
|
|
angle <- rep(45, length.out = nx)
|
|
radius = seq(1, 0, by=-1/num)[1:num]
|
|
twopi <- -2 * pi
|
|
t2xy <- function(t, rad) ({
|
|
t2p <- twopi * t + init.angle * pi/180
|
|
list(x = rad * cos(t2p), y = rad * sin(t2p))
|
|
})
|
|
# plot colored segments
|
|
for (i in 1L:nx)
|
|
({
|
|
n <- max(2, floor(200 * dx[i]))
|
|
P <- t2xy(seq.int(x[i], x[i + 1], length.out = n), rad=radius[1])
|
|
polygon(c(P$x, 0), c(P$y, 0), angle = angle[i],
|
|
border = border[i], col = col[i], lty = lty[i])
|
|
P <- t2xy(mean(x[i + 0:1]), rad=radius[1])
|
|
lab <- labels[i]
|
|
if (!is.na(lab) && nzchar(lab)) ({
|
|
adjs = 0.5
|
|
if (P$x > 1e-08) adjs <- 0
|
|
if (P$x < -1e-08) adjs <- 1
|
|
lines(c(1, 1.05) * P$x, c(1, 1.05) * P$y)
|
|
text(1.1 * P$x, 1.1 * P$y, labels[i], xpd = TRUE,
|
|
adj = adjs, cex=cex, col=labcol, ...)
|
|
})
|
|
})
|
|
# add title
|
|
title(main = main, ...)
|
|
# return color names
|
|
if (verbose)
|
|
col
|
|
}
|
|
|
|
# function to produce horizontal bar chart, colours drawn from "ochre" colour wheel defined above to match report
|
|
plot_horizontal_bar <- function(x) {
|
|
## code if a specific palette is needed for matching
|
|
fill = wheel(ochre, num = as.integer(count(x[1])))
|
|
#fill = scale_fill_brewer()
|
|
# make plot
|
|
ggplot(x, aes(x = n, y = response, fill = fill)) +
|
|
geom_col(colour = "white") +
|
|
## add percentage labels
|
|
geom_text(aes(label = perc),
|
|
## make labels left-aligned and white
|
|
hjust = 1, nudge_x = -.5, colour = "black", size=3) +
|
|
## reduce spacing between labels and bars
|
|
scale_fill_identity(guide = "none") +
|
|
## get rid of all elements except y axis labels + adjust plot margin
|
|
theme_ipsum_rc() +
|
|
theme(plot.margin = margin(rep(15, 4))) +
|
|
easy_center_title()
|
|
}
|
|
|
|
qualtrics_process_single_multiple_choice <- function(x) {
|
|
# create separate data frame
|
|
df <- as.data.frame(x)
|
|
# make column names coherent and simplified
|
|
names(df) <- c("response")
|
|
# filter out NA values
|
|
df <- filter(df, !is.na(response))
|
|
# generate new dataframe with sums per category and sort in descending order
|
|
sums <- df %>%
|
|
dplyr::count(response, sort = TRUE) %>%
|
|
dplyr::mutate(
|
|
response = forcats::fct_rev(forcats::fct_inorder(response))
|
|
)
|
|
# add new column with percentages for each sum
|
|
sums <- sums %>%
|
|
dplyr::mutate(perc = scales::percent(n / sum(n), accuracy = 1, trim = FALSE))
|
|
}
|
|
|
|
qualtrics_process_single_multiple_choice_unsorted_streamlined <- function(x) {
|
|
# create separate data frame
|
|
df <- as.data.frame(as_factor(x))
|
|
# make column names coherent and simplified
|
|
names(df) <- c("response")
|
|
# filter out NA values
|
|
df <- filter(df, !is.na(response))
|
|
# generate new dataframe with sums per category and sort in descending order
|
|
sums <- df %>%
|
|
dplyr::count(response, sort = FALSE)
|
|
# add new column with percentages for each sum
|
|
sums <- sums %>%
|
|
dplyr::mutate(perc = scales::percent(n / sum(n), accuracy = 1, trim = FALSE))
|
|
}
|
|
|
|
qualtrics_process_single_multiple_choice_basic <- function(x) {
|
|
# create separate data frame
|
|
df <- as_factor(x)
|
|
# make column names coherent and simplified
|
|
names(df) <- c("response")
|
|
# filter out NA values
|
|
df <- filter(df, !is.na(response))
|
|
# generate new dataframe with sums per category and sort in descending order
|
|
sums <- df %>%
|
|
dplyr::count(response, sort = FALSE)
|
|
# add new column with percentages for each sum
|
|
sums <- sums %>%
|
|
dplyr::mutate(perc = scales::percent(n / sum(n), accuracy = 1, trim = FALSE))
|
|
}
|
|
|
|
qualtrics_process_single_multiple_choice_unsorted <- function(x) {
|
|
# create separate data frame
|
|
df <- as.data.frame(x)
|
|
# make column names coherent and simplified
|
|
names(df) <- c("response")
|
|
# filter out NA values
|
|
df <- filter(df, !is.na(response))
|
|
# generate new dataframe with sums per category and sort in descending order
|
|
sums <- df %>%
|
|
dplyr::count(response, sort = FALSE) %>%
|
|
dplyr::mutate(
|
|
response = forcats::fct_rev(forcats::fct_inorder(response))
|
|
)
|
|
# add new column with percentages for each sum
|
|
sums <- sums %>%
|
|
dplyr::mutate(perc = scales::percent(n / sum(n), accuracy = 1, trim = FALSE))
|
|
}
|
|
|
|
# function to produce a summary table of results for a single column using flextable
|
|
|
|
chart_single_result_flextable <- function(.data, var) {
|
|
table <- table(.data)
|
|
# add calculations and convert to a flextable object
|
|
table %>%
|
|
prop.table %>% # turn this into a table of proportions
|
|
# flextable requires a dataframe
|
|
as.data.frame() %>%
|
|
set_names(c("Variable", "Count")) %>%
|
|
# arrange in descending order
|
|
arrange({{ var }}) %>%
|
|
# convert table object to a flextable()
|
|
flextable(defaults = TRUE) %>%
|
|
# adjust column widths automatically to fit widest values
|
|
style(part = 'body', pr_t=fp_text(font.family='Roboto')) %>%
|
|
style(part = 'header', pr_t=fp_text(font.family='Roboto')) %>%
|
|
# note, likert also uses set_caption() so need to specify flextable:: here
|
|
flextable::set_caption(caption, style = "Table Caption", autonum = run_autonum(seq_id = "tab", bkm = "figures", bkm_all = TRUE)) %>%
|
|
autofit() %>%
|
|
theme_vanilla() %>%
|
|
# format numbers in count column as rounded percentages
|
|
set_formatter( table, Count = function(x) sprintf( "%.1f%%", x*100 ))
|
|
}
|
|
|
|
chart_single_result_flextable_unsorted <- function(.data, var) {
|
|
table <- table(.data)
|
|
# add calculations and convert to a flextable object
|
|
table %>%
|
|
prop.table %>% # turn this into a table of proportions
|
|
# flextable requires a dataframe
|
|
as.data.frame() %>%
|
|
set_names(c("Variable", "Count")) %>%
|
|
# convert table object to a flextable()
|
|
flextable(defaults = TRUE) %>%
|
|
# adjust column widths automatically to fit widest values
|
|
style(part = 'body', pr_t=fp_text(font.family='Roboto')) %>%
|
|
style(part = 'header', pr_t=fp_text(font.family='Roboto')) %>%
|
|
# note, likert also uses set_caption() so need to specify flextable:: here
|
|
flextable::set_caption(caption, style = "Table Caption", autonum = run_autonum(seq_id = "tab", bkm = "figures", bkm_all = TRUE)) %>%
|
|
autofit() %>%
|
|
theme_vanilla() %>%
|
|
# format numbers in count column as rounded percentages
|
|
set_formatter( table, Count = function(x) sprintf( "%.1f%%", x*100 ))
|
|
}
|
|
``` |