#' @importFrom ggplot2 aes
#' @importFrom ggplot2 coord_flip
#' @importFrom ggplot2 element_blank
#' @importFrom ggplot2 element_text
#' @importFrom ggplot2 geom_blank
#' @importFrom ggplot2 geom_hline
#' @importFrom ggplot2 geom_line
#' @importFrom ggplot2 geom_rect
#' @importFrom ggplot2 geom_segment
#' @importFrom ggplot2 ggplot
#' @importFrom ggplot2 guides
#' @importFrom ggplot2 labs
#' @importFrom ggplot2 theme
#' @importFrom ggplot2 theme_bw
plot_cor_single <- function(
out, alpha = 0.05,
text_labels = TRUE,
col_palette = 0
){
out$pair <- paste(out$col_1, out$col_2, sep = ' & ')
# xlabels
df_names <- attr(out, "df_names")
method <- attr(out, "method")
mth_ind <- grep(paste0("^", method), c("pearson", "kendall", "spearman"), ignore.case = TRUE)
xlab <- c("Pearson's correlation",
"Kendall's rank correlation",
"Spearman's rank correlation")[mth_ind]
# get a vector of signficance colors from theme
vcols <- c("gray50", user_colours(9, col_palette)[9])
# factorise pairs, add a sign variable and an index
out <- out %>%
filter(!is.na(corr)) %>%
mutate(pair = factor(pair, levels = rev(unique(as.character(pair)))),
sign = as.factor(c("Negative", "Positive")[as.numeric(corr > 0) + 1])) %>%
arrange(desc(pair)) %>%
mutate(index = nrow(.):1)
# generate coloured CIs and point estimate plot
plt <- ggplot(out, aes(x = pair, y = corr)) +
geom_hline(yintercept = 0, linetype = "dashed",
color = "lightsteelblue4", na.rm = TRUE) +
geom_rect(
alpha = 0.4,
xmin = out$index - 0.4, xmax = out$index + 0.4,
ymin = out$lower, ymax = out$upper, linetype = 1,
fill = vcols[(out$p_value < alpha) + 1],
na.rm = TRUE) +
geom_segment(x = out$index - 0.4, y = out$corr,
xend = out$index + 0.4,
yend = out$corr, col = "gray40",
na.rm = TRUE) +
coord_flip() + ylim(min(out$lower), max(out$upper)) +
labs(x = "", y = xlab,
title = paste0("Correlation of columns in df::", df_names$df1))
plt
}
plot_cor_pair <- function(
out,
alpha = 0.05,
text_labels = TRUE,
col_palette = 0
){
df_names <- attr(out, "df_names")
method <- attr(out, "method")
# xlabels
mth_ind <- grep(tolower(paste0("^", method)), c("pearson", "kendal", "spearman"))
xlab <- c("Pearson's correlation",
"Kendall's rank correlation",
"Spearman's rank correlation")[mth_ind]
# create tall data from correlation table
out <- out %>%
filter(!is.na(corr_1), !is.na(corr_2)) %>%
mutate(pair = paste(col_1, col_2, sep = " & ")) %>%
mutate(pair = factor(pair, levels = rev(unique(as.character(pair))))) %>%
select(-col_1, -col_2) %>%
gather(key = "data_frame", value = "corr", -pair, -p_value) %>%
mutate(data_frame = unlist(df_names)[as.integer(gsub("corr_", "", data_frame))],
data_frame_n = as.integer(as.factor(data_frame)))
# number of dataframes
n_df <- length(unique(out$data_frame))
# get a vector of signficance colors from theme
vcols <- c("gray50", user_colours(9, col_palette)[9])
# get a vector of bar colors from theme
if(n_df == 2){
bcols <- get_best_pair(col_palette)
} else {
bcols <- user_colours(n_df, col_palette)
}
# add bar colors, significance & bar positions
out <- out %>%
mutate(index = as.integer(pair)) %>%
mutate(data_frame_n = n_df - data_frame_n + 1) %>%
mutate(bar_dn = index - 0.8 + data_frame_n * (0.8 / n_df)) %>%
mutate(bar_up = index - 0.8 + (data_frame_n + 1) * (0.8 / n_df)) %>%
mutate(bar_bg = ifelse(corr < 0, corr, 0), bar_en = ifelse(corr < 0, 0, corr))
# generate basic plot
plt <- out %>%
ggplot(aes(x = pair, y = corr, fill = data_frame)) +
geom_blank() + theme_bw() +
theme(panel.border = element_blank(), panel.grid.major = element_blank()) +
geom_rect(
fill = vcols[as.integer(out$p_value < alpha) + 1], alpha = 0.2,
xmin = out$index - 0.4, xmax = out$index + 0.4,
ymin = -2, ymax = 2, linetype = "blank") +
geom_rect(
linetype = "blank",
xmin = out$bar_dn, xmax = out$bar_up,
ymin = out$bar_bg, ymax = out$bar_en) +
geom_hline(yintercept = 0, linetype = "dashed",
color = "lightsteelblue4", na.rm = TRUE) +
coord_flip() +
labs(y = xlab, x = "",
title = paste0("Comparison of \u03C1 between df::", df_names$df1,
" and ", df_names$df2)) +
scale_fill_manual(name = "Data frame", values = bcols)
plt
}
plot_cor_grouped <- function(
out,
alpha = 0.05,
text_labels = TRUE,
col_palette = 0,
plot_type = 1
){
df_names <- attr(out, "df_names")
method <- attr(out, "method")
# group variable name
group_name <- colnames(out)[1]
if(plot_type == 1){
# get ordering of variable pairs by median correlation
col_ord <- out %>%
ungroup %>%
mutate(pair = paste0(col_1, ' & ', col_2)) %>%
group_by(pair) %>%
summarize(md_cor = median(corr, na.rm = T)) %>%
arrange(md_cor) %>%
.$pair
# create pair columns and arrange by col_ord
out <- out %>%
ungroup %>%
mutate(pair = paste0(col_1, ' & ', col_2)) %>%
mutate(pair = factor(pair, levels = col_ord)) %>%
arrange(pair)
# jitter points if number of column pairs <= 10
jitter_width <- ifelse(length(unique(out$pair)) > 10, 0, 0.25)
plt <- out %>%
ggplot(aes_string(x = 'pair', y = 'corr', col = 'pair', group = group_name)) +
geom_jitter(alpha = 0.5, width = jitter_width, size = 1.8, na.rm = TRUE) +
theme(legend.position='none') +
coord_flip() +
ylab("Correlation by group") +
xlab("")
} else {
new_out <- out %>%
mutate(pair = paste(col_1, col_2, sep = " & ")) %>%
mutate(pair = factor(pair, levels = rev(unique(as.character(pair))))) %>%
select(-col_1, -col_2, -lower, -upper, -p_value)
plt <- plot_grouped(
df = new_out,
value = "corr",
series = "pair",
group = group_name,
plot_type = plot_type,
col_palette = col_palette,
text_labels = text_labels,
ylab = "Correlation")
plt <- plt +
geom_hline(yintercept = 0, alpha = 0.5, linetype = "dashed") +
geom_hline(yintercept = 1, alpha = 0.3, linetype = "dashed") +
geom_hline(yintercept = -1, alpha = 0.3, linetype = "dashed")
}
return(plt)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.