R/gplot.R
In jdgagnon/plotGrouper: Shiny app GUI wrapper for ggplot with built-in statistical analysis
# Copyright 2017-2018 John Gagnon
# This program is distributed under the terms of the GNU General Public License
#' A function to create a grouped plot and return a table grob.
#'
#' This function allows you to create a grouped plot and return a table grob.
#' It takes a tidy dataset containing sample replicate values for at least one
#' variable, a column organizing each replicate into the proper comparison
#' group, and a column that groups the variables to be plotted. Additional
#' arguments allow for the re-ordering of the variables and the
#' comparisons being ploted, selection of the type of graph to display (e.g.,
#' bar graph, boxplot, violin plot, points, statistical summary, etc...), as
#' well as other aesthetics of the plot.
#' @import shiny
#' @import shinythemes
#' @import dplyr
#' @import ggplot2
#' @rawNamespace import(Hmisc, except = c(summarize, src))
#' @importFrom rlang .data
#' @importFrom tibble as.tibble
#' @importFrom grid convertUnit nullGrob
#' @importFrom gridExtra grid.arrange arrangeGrob
#' @importFrom egg set_panel_size
#' @importFrom readxl excel_sheets read_excel
#' @importFrom ggpubr compare_means get_legend
#' @importFrom gtable gtable_add_padding
#' @importFrom readr parse_number read_csv read_tsv
#' @importFrom scales trans_format math_format rescale_none
#' @importFrom stringr str_remove str_split word
#' @importFrom tidyr gather
#' @importFrom stats na.omit start
#' @importFrom colourpicker colourInput updateColourInput
#' @param dataset Define your data set which should be a gathered tibble
#' @param comparison Specify the comparison you would like to make
#' (e.g., Genotype)
#' @param group.by Specify the variable to group by (e.g., Tissue).
#' @param levs Specify the order of the grouping variables
#' @param val Specify column name that contains values (optional)
#' @param geom Define the list of geoms you want to plot
#' @param p Specify representation of pvalue
#' (p.signif = astrisk representation of the raw p value;
#' p.format = 'p = 0.05';
#' p.adj = adjusted p-value;
#' p.adj.signif = astrisk representation of the adjusted p value)
#' @param ref.group Specify a reference group to compare all other
#' comparisons to
#' @param p.adjust.method Method used for adjusting the pvalue
#' @param method Specify the statistical test to be used
#' @param paired Specify whether or not the statistical comparisons should be
#' paired
#' @param errortype Specify the method of statistical error to plot
#' @param comparisons Specify which of the available comparisons within your
#' data you would like to plot
#' @param y.lim Specify the min and max values to be used for the y-axis
#' @param y.lab Specify a custom y-axis label to use
#' @param expand.y Specify values to expand the y-axis
#' @param trans.y Specify the transformation to perform on the dependent
#' variable
#' @param x.lim Specify the min and max values to be used for the x-axis
#' @param x.lab Specify a custom x-axis label to use
#' @param trans.x Specify the transformation to perform on the independent
#' variable
#' @param sci Specify whether or not to display the dependent variable using
#' scientific notation
#' @param angle.x Specify whether or not to angle the x-axis text 45deg
#' @param levs.comps Specify the order in which to plot the comparisons
#' @param group.labs Specify custom labels for the independent variables
#' @param stats Specify whether or not to output the statistics table
#' @param split Specify whether or not to split the x-axis label text
#' @param split_str Specify the string to split the x-axis label text by; uses
#' regex
#' @param trim Specify the string to trim text from the right side of the
#' x-axis label text; uses regex
#' @param leg.pos Specify where to place the legend
#' @param stroke Specify the line thickness to use
#' @param font_size Specify the font size to use
#' @param size Specify the size of the points to use
#' @param width Specify the width of groups to be plotted
#' @param dodge Specify the width to dodge the comparisons by
#' @param plotWidth Specify the length of the x-axis in mm
#' @param plotHeight Specify the length of the y-axis in mm
#' @param shape.groups Specify the default shapes to use for the comparisons
#' @param color.groups Specify the default colors to use for the comparisons
#' @param fill.groups Specify the default fills to use for the comparisons
#' @return Table grob of the plot
#' @examples
#' iris %>% dplyr::mutate(Species = as.character(Species)) %>%
#' dplyr::group_by(Species) %>%
#' dplyr::mutate(Sample = paste0(Species, "_", dplyr::row_number()),
#' Sheet = "iris") %>%
#' dplyr::select(Sample, Sheet, Species, dplyr::everything()) %>%
#' tidyr::gather(variable, value, -c(Sample, Sheet, Species)) %>%
#' dplyr::filter(variable == "Sepal.Length") %>%
#' plotGrouper::gplot(
#' comparison = "Species",
#' group.by = "variable",
#' shape.groups = c(19,21,17),
#' color.groups = c(rep("black",3)),
#' fill.groups = c("black","#E016BE", "#1243C9")) %>%
#' gridExtra::grid.arrange()
#' @export
gplot <- function(dataset = NULL,
comparison = NULL,
group.by = NULL,
levs = TRUE,
val = "value",
geom = c("bar",
"errorbar",
"point",
"stat",
"seg"),
p = "p.signif",
ref.group = NULL,
p.adjust.method = "holm",
comparisons = NULL,
method = "t.test",
paired = FALSE,
errortype = "mean_sdl",
y.lim = NULL,
y.lab = NULL,
trans.y = "identity",
x.lim = c(NA, NA),
expand.y = c(0, 0),
x.lab = NULL,
trans.x = "identity",
sci = FALSE,
angle.x = FALSE,
levs.comps = TRUE,
group.labs = NULL,
stats = FALSE,
split = TRUE,
split_str = NULL,
trim = "none",
leg.pos = "top",
stroke = 0.25,
font_size = 9,
size = 1,
width = 0.8,
dodge = 0.8,
plotWidth = 30,
plotHeight = 40,
shape.groups = c(19, 21),
color.groups = c("black", "black"),
fill.groups = c("#444444", NA, "#A33838")) {
. <- "Stop NOTE"
df <- droplevels(dataset)
# If the column of values has a different column name than 'value',
# assign it 'value'
colnames(df)[colnames(df) == val] <- "value"
df$value <- as.numeric(df$value)
# If comparison variable is not a factor, coerce it to one
if (!is.factor(df[[comparison]])) {
df[, comparison] <- factor(df[[comparison]],
levels = unique(df[[comparison]])[levs.comps])
}
df <- dplyr::arrange_(df, comparison)
# Assign labels to the groups
suppressWarnings(if (is.null(group.labs) & split == FALSE) {
group.labs <- function(x) {
x
}
} else if (is.null(group.labs) &
split & is.null(split_str)) {
group.labs <- function(x) {
vapply(stringr::str_remove(
stringr::word(stringr::str_remove(x, trim),-1,
sep = "/"),
" %| #|% |# "
),
"[",
FUN.VALUE = "",
1)
}
} else if (is.null(group.labs) &
split & !is.null(split_str)) {
group.labs <- function(x) {
vapply(
strsplit(
stringr::str_remove(x, trim),
split = split_str,
fixed = TRUE
),
"[",
FUN.VALUE = "",
2
)
}
} else {
group.labs <- group.labs
})
# If grouping variable is not numeric, scale x discretely, and assign levels.
# If it is numeric, scale x continuously
if (is.factor(df[[group.by]])) {
scale.x <- ggplot2::scale_x_discrete(labels = group.labs,
breaks = unique(df[[group.by]]))
} else if (!is.numeric(df[[group.by]]) &
!is.factor(df[[group.by]])) {
df[, group.by] <- factor(df[[group.by]],
levels = unique(df[[group.by]])[levs])
scale.x <- ggplot2::scale_x_discrete(labels = group.labs,
breaks = unique(df[[group.by]]))
} else {
scale.x <- ggplot2::scale_x_continuous(
breaks = df[[group.by]],
labels = formatC(df[[group.by]],
drop0trailing = TRUE),
trans = trans.x,
limits = x.lim
)
}
# Create a tibble of max values by group for assigning height of p values
d_min <- droplevels(
df %>%
dplyr::group_by_(group.by, comparison) %>%
dplyr::mutate("min_error" = min(
get(errortype)(.data$value, mult = 1),
na.rm = TRUE)) %>%
dplyr::ungroup() %>%
dplyr::group_by_(group.by) %>%
dplyr::slice(which.min(.data$value)) %>%
dplyr::mutate("min_value" = .data$value) %>%
dplyr::select_(group.by,
"min_value",
"min_error") %>%
dplyr::ungroup() %>%
dplyr::mutate("min" = min(c(.data$min_value,
.data$min_error),
na.rm = TRUE)) %>%
dplyr::arrange_(group.by)
)
d_max <- droplevels(
df %>%
dplyr::group_by_(group.by, comparison) %>%
dplyr::mutate(
"max_error" = max(
get(errortype)(.data$value, mult = 1),
na.rm = TRUE)) %>%
dplyr::ungroup() %>%
dplyr::group_by_(group.by) %>%
dplyr::slice(which.max(.data$value)) %>%
dplyr::mutate("max_value" = .data$value) %>%
dplyr::select_(group.by,
"max_value",
"max_error") %>%
dplyr::ungroup() %>%
dplyr::arrange_(group.by)
)
d_min_max <- dplyr::left_join(d_min, d_max, by = group.by)
# If no comparisons are specified, perform all comparisons
if (is.null(comparisons)) {
comparisons <- df[[comparison]]
}
symnum.args <- list(
cutpoints = c(0, 0.0001, 0.001, 0.01, 0.05, 1),
symbols = c("****", "***", "**", "*", NA)
)
# Calculate p values for all comparisons being made
statOut <- try(ggpubr::compare_means(
formula = stats::formula(paste("value", "~", comparison)),
data = df,
method = method,
group.by = group.by,
ref.group = ref.group,
paired = paired,
symnum.args = symnum.args,
p.adjust.method = p.adjust.method) %>%
mutate("p.adj.method" = p.adjust.method))
statOut$p.adj.signif <- try(vapply(X = statOut$p.adj,
FUN = stats::symnum,
FUN.VALUE = "",
cutpoints = symnum.args$cutpoints,
symbols = symnum.args$symbols))
if (method %in% c("t.test", "wilcox.test")) {
statistics <- try(dplyr::left_join(statOut, d_max, by = group.by) %>%
dplyr::filter(.data$group1 %in% comparisons |
.data$group2 %in% comparisons) %>%
# Find max value (individual point or errorbar)
dplyr::mutate("max" = max(c(.data$max_value,
.data$max_error),
na.rm = TRUE)) %>%
dplyr::group_by_(group.by) %>%
dplyr::mutate(
"max_group" = max(c(.data$max_value,
.data$max_error),
na.rm = TRUE),
# Row number
"n" = dplyr::row_number(),
# First comparison group
"group1" = factor(.data$group1,
levels = levels(df[[comparison]])),
# Second comparison group
"group2" = factor(.data$group2,
levels = levels(df[[comparison]])),
# Adjustment of the height of the segment
"r" = dplyr::if_else(p == "p.signif" |
p == "p.adj.signif",
.data$max * 0.1 * 0.05,
.data$max * 0.2 * 0.05),
# Adjustment of the hieght of the stats
"e" = .data$max * .data$n * 0.05,
# Number of comparisons
"n_comps" = max(.data$n),
# Number of grouping variables
"group.by_n" = as.numeric(get(group.by)),
# Group number associated with first comparison group
"group1_n" = as.integer(.data$group1),
# Group number associated with second comparison group
"group2_n" = as.integer(.data$group2),
# Relative width of 1 bar
"unit" = (width / max(.data$group2_n)) *
dodge /
width,
# Center position of the first bar
"start" = .data$group.by_n -
.data$unit *
max(.data$group2_n) / 2,
# Center position of group1
"w.start" = .data$start +
(.data$group1_n - 1) *
.data$unit +
.data$unit /
2,
# Center position of group2
"w.stop" = .data$start +
(.data$group2_n - 1) *
.data$unit +
.data$unit / 2
) %>%
dplyr::ungroup() %>%
dplyr::mutate(
# Center of comparison line segment
"x.pos" = rowMeans(.[, c("w.start",
"w.stop")]),
# Update w.start if p.signif is.na()
"w.start" = ifelse(!is.na(.data$p.signif),
.data$w.start, NA),
# Update w.stop if p.signif is.na()
"w.stop" = ifelse(!is.na(.data$p.signif),
.data$w.stop, NA),
# Adjust height of stats
"h.p" = .data$max_group + .data$e,
# Adjust height of comparison line segment
"h.s" = .data$max_group + .data$e - .data$r
))
} else {
statistics <- try(dplyr::left_join(statOut, d_max, by = group.by) %>%
# Find max value (individual point or errorbar)
dplyr::mutate("max" = max(c(max_value, max_error),
na.rm = T)) %>%
dplyr::group_by_(group.by) %>%
dplyr::mutate(
"max_group" = max(c(.data$max_value,
.data$max_error),
na.rm = TRUE),
"n" = dplyr::row_number(),
"r" = dplyr::if_else(p == "p.signif" |
p == "p.adj.signif",
max * 0.1 * 0.05,
max * 0.2 * 0.05),
"e" = .data$max * .data$n * 0.05,
"n_comps" = max(.data$n),
"group.by_n" = as.numeric(get(group.by)),
"w.start" = .data$group.by_n -
width / length(unique(df[[comparison]])),
"w.stop" = .data$group.by_n +
width /
length(unique(df[[comparison]]))
) %>%
dplyr::ungroup() %>%
dplyr::mutate(
"x.pos" = rowMeans(.[, c("w.start", "w.stop")]),
# center of segment
"w.start" = ifelse(!is.na(.data$p.signif),
.data$w.start,
NA),
"w.stop" = ifelse(!is.na(.data$p.signif),
.data$w.stop,
NA),
"h.p" = .data$max_group + .data$e,
"h.s" = .data$max_group + .data$e - .data$r
))
}
if (("try-error" %in% class(statOut))) {
statistics <- dplyr::tibble("p.signif" = NA)
}
if (("try-error" %in% class(statistics))) {
statistics <- dplyr::tibble("p.signif" = NA)
}
if (stats) {
return(statOut)
}
# Specify y-axis limits
if (all(is.na(y.lim))) {
y.lim <-
c(0, max(d_max[, c("max_value", "max_error")], na.rm = TRUE) * 1.08)
}
if (!is.na(y.lim[1]) & is.na(y.lim[2])) {
y.lim <- c(y.lim[1], max(d_max[, c("max_value", "max_error")],
na.rm = TRUE) * 1.08)
}
if (!is.na(y.lim[2] & is.na(y.lim[1]))) {
y.lim <- c(0, y.lim[2])
}
# Adjust y limits if y transformation
# if (trans.y != "identity" & !all(is.na(statistics$p.signif))) {
# logBase <- readr::parse_number(trans.y)
# # statistics <- statistics %>%
# # dplyr::mutate("h.p" = .data$h.p * logBase,
# # "h.s" = .data$h.s * logBase)
#
# }
# If not specified by user, set y axis label to the variable being plotted.
if (is.null(y.lab)) {
y.lab <- unique(df$variable)
if (length(y.lab) > 1) {
y.lab <- y.lab[1]
}
}
# Make pretty scientific notation
max_e <- as.numeric(stringr::str_split(
string = format(max(c(
d_max$max_value,
d_max$max_error
)),
scientific = TRUE),
pattern = "e\\+"
)[[1]][2])
fancy_scientific <- function(l) {
l <- format(l, scientific = TRUE)
e <- as.numeric(vapply(l, function(a) {
stringr::str_split(a, pattern = "e\\+")[[1]][2]
}, ""))
e_dif <- as.numeric(vapply(e, function(x) {
(max_e - x)
}, numeric(1)))
l <- as.numeric(vapply(l, function(x) {
stringr::str_split(string = x, pattern = "e\\+")[[1]][1]
}, ""))
l2 <- c()
for (i in seq_len(length(e))) {
l2[i] <- ifelse(e[i] == 0, l[i],
ifelse(e[i] < max_e, (10 ^ -e_dif[i]) * l[i], l[i]))
}
format(l2, trim = FALSE)
}
if (angle.x) {
angle <- 45
vjust <- 1
hjust <- 1
} else {
angle <- 0
vjust <- 0
hjust <- 0.5
}
if (sci) {
labs.y <- fancy_scientific
y.lab <-
bquote(.(paste0(gsub(
"\\s*#\\s*", "", y.lab
), " "))(10 ^ .(max_e)))
} else {
labs.y <- ggplot2::waiver()
}
if (trans.y != "identity") {
assign("statistics", statistics, envir = globalenv())
.x <- NULL
if (trans.y == "log2") {
labs.y <- scales::trans_format(trans.y, scales::math_format(2 ^ .x))
} else {
labs.y <- scales::trans_format(trans.y, scales::math_format(10 ^ .x))
}
if (min(d_min$min, na.rm = TRUE) >= 0) {
y.lim <-
c(NA,
max(d_max[, c("max_value", "max_error")], na.rm = TRUE) * 1.08)
}
if (min(d_min$min, na.rm = TRUE) < 0) {
y.lim <-
c(NA,
max(d_max[, c("max_value", "max_error")], na.rm = TRUE) * 1.08)
}
}
# Assign names to the shape, fill, color, and alpha arguments
for (x in c("shape.groups", "fill.groups", "color.groups")) {
assign(x, stats::setNames(object = get(x), levels(df[[comparison]])))
}
# Create geoms
crossbar <- ggplot2::stat_summary(
ggplot2::aes(
group = get(comparison),
color = get(comparison)
),
fun.y = mean,
fun.ymax = mean,
fun.ymin = mean,
size = stroke / 3,
geom = "crossbar",
width = width,
position = ggplot2::position_dodge(dodge)
)
point <- ggplot2::geom_point(
ggplot2::aes(
shape = get(comparison),
color = get(comparison)
),
stroke = stroke,
size = size,
position = ggplot2::position_jitterdodge(jitter.width = 0.25,
dodge.width = dodge)
)
point_noJitter <- ggplot2::geom_point(
ggplot2::aes(
shape = get(comparison),
color = get(comparison)
),
stroke = stroke,
size = size,
position = ggplot2::position_dodge(dodge)
)
errorbar <-
ggplot2::stat_summary(
ggplot2::aes(group = get(comparison)),
fun.data = errortype,
fun.args = list(mult = 1),
geom = "errorbar",
color = "black",
width = 0.25 * width,
position = ggplot2::position_dodge(dodge),
size = stroke
)
bar <- ggplot2::stat_summary(
ggplot2::aes(fill = get(comparison)),
color = "black",
fun.y = mean,
size = stroke,
geom = "bar",
width = width,
position = ggplot2::position_dodge(dodge),
show.legend = TRUE
)
violin <- ggplot2::geom_violin(
ggplot2::aes(fill = get(comparison),
color = get(comparison)),
show.legend = TRUE,
position = ggplot2::position_dodge(dodge)
)
box <- ggplot2::geom_boxplot(
ggplot2::aes(color = get(comparison),
fill = get(comparison)),
show.legend = TRUE,
position = ggplot2::position_dodge(dodge)
)
line <- ggplot2::stat_summary(
ggplot2::aes(
group = get(comparison),
color = get(comparison)
),
fun.y = mean,
geom = "line",
size = stroke
)
line_error <-
ggplot2::stat_summary(
ggplot2::aes(group = get(comparison)),
fun.data = errortype,
fun.args = list(mult = 1),
geom = "errorbar",
color = "black",
width = 0.25 * width,
size = stroke
)
line_point <- ggplot2::stat_summary(
ggplot2::aes(
fill = get(comparison),
shape = get(comparison),
color = get(comparison)
),
stroke = stroke,
size = size,
fun.y = mean,
geom = "point"
)
dot <-
ggplot2::geom_dotplot(
ggplot2::aes(color = get(comparison)),
binaxis = "y",
stackdir = "center",
method = "histodot",
position = ggplot2::position_dodge(dodge)
)
density <- ggplot2::geom_density(ggplot2::aes(
color = get(comparison),
fill = get(comparison),
x = .data$value
),
inherit.aes = FALSE)
if (all(is.na(statOut$p.signif))) {
geom <- geom[which(!geom %in% c("stat", "seg"))]
} else {
stat <- ggplot2::geom_text(
data = statistics,
ggplot2::aes(.data$x.pos, stats::na.omit(.data$h.p)),
label = statistics[[p]],
size = font_size / (1 / 0.35),
inherit.aes = FALSE,
na.rm = TRUE
)
seg <- ggplot2::geom_segment(
data = statistics,
ggplot2::aes(
x = .data$w.start,
xend = .data$w.stop,
y = .data$h.s,
yend = .data$h.s
),
size = stroke,
inherit.aes = FALSE,
na.rm = TRUE
)
}
suppressWarnings(if ("line_point_stat" %in% geom) {
geom <- c("line", "line_error", "line_point", "stat")
})
suppressWarnings(if ("density" %in% geom) {
scale.x <-
ggplot2::scale_x_continuous(expand = c(0, 0), limits = x.lim)
y.lim <- c(0, NA)
})
# Create ggplot object and plot
g <- ggplot2::ggplot(data = df,
ggplot2::aes(x = get(group.by),
y = .data$value)) +
ggplot2::labs(
x = x.lab,
y = y.lab,
color = comparison,
shape = comparison,
fill = comparison,
alpha = comparison,
hjust = 0.5
) +
ggplot2::scale_y_continuous(
limits = y.lim,
expand = expand.y,
labels = labs.y,
trans = trans.y,
oob = scales::rescale_none
) +
scale.x +
ggplot2::scale_shape_manual(values = shape.groups) +
ggplot2::scale_fill_manual(values = fill.groups) +
ggplot2::scale_color_manual(values = color.groups) +
lapply(geom, function(x)
get(x)) +
ggplot2::theme(
line = ggplot2::element_line(colour = "black",
size = stroke),
text = ggplot2::element_text(size = font_size,
colour = "black"),
rect = ggplot2::element_blank(),
panel.grid = ggplot2::element_blank(),
legend.position = leg.pos,
legend.title = ggplot2::element_text(size = font_size,
colour = "black"),
legend.text = ggplot2::element_text(size = font_size,
colour = "black"),
axis.line.x = ggplot2::element_line(colour = "black", size = stroke),
axis.line.y = ggplot2::element_line(colour = "black", size = stroke),
axis.ticks.x = ggplot2::element_blank(),
axis.text.x = ggplot2::element_text(
size = font_size,
colour = "black",
angle = angle,
vjust = vjust,
hjust = hjust
),
axis.text = ggplot2::element_text(size = font_size,
colour = "black"),
plot.margin = ggplot2::margin(5, 0, 5, 0, "mm"),
legend.margin = ggplot2::margin(0, 0, 0, 0, "mm")
)
if (stats == FALSE) {
if (leg.pos %in% c("top", "bottom")) {
leg <- ggpubr::get_legend(g)
lwidth <- sum(as.numeric(grid::convertUnit(leg$width, "mm")))
} else {
lwidth <- 0
}
gt <- egg::set_panel_size(
g,
width = ggplot2::unit(plotWidth, "mm"),
height = ggplot2::unit(plotHeight, "mm")
)
gt$layout$clip[gt$layout$name == "panel"] <- "off"
# rect grobs such as those created by geom_bar() have "height" / "width"
# measurements, while point & text grobs have "y" / "x" measurements,
# & we look for both
max.grob.heights <- vapply(gt$grob[[which(
gt$layout$name == "panel")]]$children,
function(x)
ifelse(
!is.null(x$height) &
"unit" %in% class(x$height),
max(as.numeric(x$height), na.rm = TRUE),
ifelse(!is.null(x$y) &
"unit" %in% class(x$y),
max(as.numeric(x$y)),
0)
), numeric(1))
max.grob.heights <- max(max.grob.heights, na.rm = TRUE)
min.grob.heights <- vapply(gt$grob[[which(
gt$layout$name == "panel")]]$children,
function(x)
ifelse(
!is.null(x$height) &
"unit" %in% class(x$height),
min(as.numeric(x$height),
na.rm = TRUE),
ifelse(!is.null(x$y) &
"unit" %in% class(x$y),
min(as.numeric(x$y)),
0)
), numeric(1))
min.grob.heights <- min(min.grob.heights, na.rm = TRUE)
# identify panel row & calculate panel height
panel.row <- gt$layout[gt$layout$name == "panel", "t"] # = 7
panel.height <-
as.numeric(grid::convertUnit(gt$heights[panel.row], "mm"))
# calculate height of all the grobs above the panel
height.above.panel <- gt$heights[seq_len(panel.row - 1)]
height.above.panel <- sum(as.numeric(
grid::convertUnit(height.above.panel, "mm")), na.rm = TRUE)
# check whether the out-of-bound object (if any) exceeds this height,
# & replace if necessary
if (max.grob.heights > 1) {
oob.height.above.panel <- (max.grob.heights - 1) * panel.height
height.above.panel <-
max(height.above.panel, oob.height.above.panel,
na.rm = TRUE)
}
# as above, calculate the height of all the grobs below the panel
height.below.panel <-
gt$heights[(panel.row + 1):length(gt$heights)]
height.below.panel <- sum(as.numeric(
grid::convertUnit(height.below.panel, "mm")), na.rm = TRUE)
# as above
if (min.grob.heights < 0) {
oob.height.below.panel <- abs(min.grob.heights) * panel.height
height.below.panel <-
max(height.below.panel, oob.height.below.panel,
na.rm = TRUE)
}
# sum the result
pheight <-
height.above.panel + panel.height + height.below.panel
gt <- gtable::gtable_add_padding(gt,
padding = ggplot2::unit(c(
height.above.panel,
lwidth / 2,
5,
lwidth / 2
), "mm"))
return(gt)
}
}
jdgagnon/plotGrouper documentation built on May 14, 2019, 11:12 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
# Copyright 2017-2018 John Gagnon
# This program is distributed under the terms of the GNU General Public License
#' A function to create a grouped plot and return a table grob.
#'
#' This function allows you to create a grouped plot and return a table grob.
#' It takes a tidy dataset containing sample replicate values for at least one
#' variable, a column organizing each replicate into the proper comparison
#' group, and a column that groups the variables to be plotted. Additional
#' arguments allow for the re-ordering of the variables and the
#' comparisons being ploted, selection of the type of graph to display (e.g.,
#' bar graph, boxplot, violin plot, points, statistical summary, etc...), as
#' well as other aesthetics of the plot.
#' @import shiny
#' @import shinythemes
#' @import dplyr
#' @import ggplot2
#' @rawNamespace import(Hmisc, except = c(summarize, src))
#' @importFrom rlang .data
#' @importFrom tibble as.tibble
#' @importFrom grid convertUnit nullGrob
#' @importFrom gridExtra grid.arrange arrangeGrob
#' @importFrom egg set_panel_size
#' @importFrom readxl excel_sheets read_excel
#' @importFrom ggpubr compare_means get_legend
#' @importFrom gtable gtable_add_padding
#' @importFrom readr parse_number read_csv read_tsv
#' @importFrom scales trans_format math_format rescale_none
#' @importFrom stringr str_remove str_split word
#' @importFrom tidyr gather
#' @importFrom stats na.omit start
#' @importFrom colourpicker colourInput updateColourInput
#' @param dataset Define your data set which should be a gathered tibble
#' @param comparison Specify the comparison you would like to make
#' (e.g., Genotype)
#' @param group.by Specify the variable to group by (e.g., Tissue).
#' @param levs Specify the order of the grouping variables
#' @param val Specify column name that contains values (optional)
#' @param geom Define the list of geoms you want to plot
#' @param p Specify representation of pvalue
#' (p.signif = astrisk representation of the raw p value;
#' p.format = 'p = 0.05';
#' p.adj = adjusted p-value;
#' p.adj.signif = astrisk representation of the adjusted p value)
#' @param ref.group Specify a reference group to compare all other
#' comparisons to
#' @param p.adjust.method Method used for adjusting the pvalue
#' @param method Specify the statistical test to be used
#' @param paired Specify whether or not the statistical comparisons should be
#' paired
#' @param errortype Specify the method of statistical error to plot
#' @param comparisons Specify which of the available comparisons within your
#' data you would like to plot
#' @param y.lim Specify the min and max values to be used for the y-axis
#' @param y.lab Specify a custom y-axis label to use
#' @param expand.y Specify values to expand the y-axis
#' @param trans.y Specify the transformation to perform on the dependent
#' variable
#' @param x.lim Specify the min and max values to be used for the x-axis
#' @param x.lab Specify a custom x-axis label to use
#' @param trans.x Specify the transformation to perform on the independent
#' variable
#' @param sci Specify whether or not to display the dependent variable using
#' scientific notation
#' @param angle.x Specify whether or not to angle the x-axis text 45deg
#' @param levs.comps Specify the order in which to plot the comparisons
#' @param group.labs Specify custom labels for the independent variables
#' @param stats Specify whether or not to output the statistics table
#' @param split Specify whether or not to split the x-axis label text
#' @param split_str Specify the string to split the x-axis label text by; uses
#' regex
#' @param trim Specify the string to trim text from the right side of the
#' x-axis label text; uses regex
#' @param leg.pos Specify where to place the legend
#' @param stroke Specify the line thickness to use
#' @param font_size Specify the font size to use
#' @param size Specify the size of the points to use
#' @param width Specify the width of groups to be plotted
#' @param dodge Specify the width to dodge the comparisons by
#' @param plotWidth Specify the length of the x-axis in mm
#' @param plotHeight Specify the length of the y-axis in mm
#' @param shape.groups Specify the default shapes to use for the comparisons
#' @param color.groups Specify the default colors to use for the comparisons
#' @param fill.groups Specify the default fills to use for the comparisons
#' @return Table grob of the plot
#' @examples
#' iris %>% dplyr::mutate(Species = as.character(Species)) %>%
#' dplyr::group_by(Species) %>%
#' dplyr::mutate(Sample = paste0(Species, "_", dplyr::row_number()),
#' Sheet = "iris") %>%
#' dplyr::select(Sample, Sheet, Species, dplyr::everything()) %>%
#' tidyr::gather(variable, value, -c(Sample, Sheet, Species)) %>%
#' dplyr::filter(variable == "Sepal.Length") %>%
#' plotGrouper::gplot(
#' comparison = "Species",
#' group.by = "variable",
#' shape.groups = c(19,21,17),
#' color.groups = c(rep("black",3)),
#' fill.groups = c("black","#E016BE", "#1243C9")) %>%
#' gridExtra::grid.arrange()
#' @export
gplot <- function(dataset = NULL,
comparison = NULL,
group.by = NULL,
levs = TRUE,
val = "value",
geom = c("bar",
"errorbar",
"point",
"stat",
"seg"),
p = "p.signif",
ref.group = NULL,
p.adjust.method = "holm",
comparisons = NULL,
method = "t.test",
paired = FALSE,
errortype = "mean_sdl",
y.lim = NULL,
y.lab = NULL,
trans.y = "identity",
x.lim = c(NA, NA),
expand.y = c(0, 0),
x.lab = NULL,
trans.x = "identity",
sci = FALSE,
angle.x = FALSE,
levs.comps = TRUE,
group.labs = NULL,
stats = FALSE,
split = TRUE,
split_str = NULL,
trim = "none",
leg.pos = "top",
stroke = 0.25,
font_size = 9,
size = 1,
width = 0.8,
dodge = 0.8,
plotWidth = 30,
plotHeight = 40,
shape.groups = c(19, 21),
color.groups = c("black", "black"),
fill.groups = c("#444444", NA, "#A33838")) {
. <- "Stop NOTE"
df <- droplevels(dataset)
# If the column of values has a different column name than 'value',
# assign it 'value'
colnames(df)[colnames(df) == val] <- "value"
df$value <- as.numeric(df$value)
# If comparison variable is not a factor, coerce it to one
if (!is.factor(df[[comparison]])) {
df[, comparison] <- factor(df[[comparison]],
levels = unique(df[[comparison]])[levs.comps])
}
df <- dplyr::arrange_(df, comparison)
# Assign labels to the groups
suppressWarnings(if (is.null(group.labs) & split == FALSE) {
group.labs <- function(x) {
x
}
} else if (is.null(group.labs) &
split & is.null(split_str)) {
group.labs <- function(x) {
vapply(stringr::str_remove(
stringr::word(stringr::str_remove(x, trim),-1,
sep = "/"),
" %| #|% |# "
),
"[",
FUN.VALUE = "",
1)
}
} else if (is.null(group.labs) &
split & !is.null(split_str)) {
group.labs <- function(x) {
vapply(
strsplit(
stringr::str_remove(x, trim),
split = split_str,
fixed = TRUE
),
"[",
FUN.VALUE = "",
2
)
}
} else {
group.labs <- group.labs
})
# If grouping variable is not numeric, scale x discretely, and assign levels.
# If it is numeric, scale x continuously
if (is.factor(df[[group.by]])) {
scale.x <- ggplot2::scale_x_discrete(labels = group.labs,
breaks = unique(df[[group.by]]))
} else if (!is.numeric(df[[group.by]]) &
!is.factor(df[[group.by]])) {
df[, group.by] <- factor(df[[group.by]],
levels = unique(df[[group.by]])[levs])
scale.x <- ggplot2::scale_x_discrete(labels = group.labs,
breaks = unique(df[[group.by]]))
} else {
scale.x <- ggplot2::scale_x_continuous(
breaks = df[[group.by]],
labels = formatC(df[[group.by]],
drop0trailing = TRUE),
trans = trans.x,
limits = x.lim
)
}
# Create a tibble of max values by group for assigning height of p values
d_min <- droplevels(
df %>%
dplyr::group_by_(group.by, comparison) %>%
dplyr::mutate("min_error" = min(
get(errortype)(.data$value, mult = 1),
na.rm = TRUE)) %>%
dplyr::ungroup() %>%
dplyr::group_by_(group.by) %>%
dplyr::slice(which.min(.data$value)) %>%
dplyr::mutate("min_value" = .data$value) %>%
dplyr::select_(group.by,
"min_value",
"min_error") %>%
dplyr::ungroup() %>%
dplyr::mutate("min" = min(c(.data$min_value,
.data$min_error),
na.rm = TRUE)) %>%
dplyr::arrange_(group.by)
)
d_max <- droplevels(
df %>%
dplyr::group_by_(group.by, comparison) %>%
dplyr::mutate(
"max_error" = max(
get(errortype)(.data$value, mult = 1),
na.rm = TRUE)) %>%
dplyr::ungroup() %>%
dplyr::group_by_(group.by) %>%
dplyr::slice(which.max(.data$value)) %>%
dplyr::mutate("max_value" = .data$value) %>%
dplyr::select_(group.by,
"max_value",
"max_error") %>%
dplyr::ungroup() %>%
dplyr::arrange_(group.by)
)
d_min_max <- dplyr::left_join(d_min, d_max, by = group.by)
# If no comparisons are specified, perform all comparisons
if (is.null(comparisons)) {
comparisons <- df[[comparison]]
}
symnum.args <- list(
cutpoints = c(0, 0.0001, 0.001, 0.01, 0.05, 1),
symbols = c("****", "***", "**", "*", NA)
)
# Calculate p values for all comparisons being made
statOut <- try(ggpubr::compare_means(
formula = stats::formula(paste("value", "~", comparison)),
data = df,
method = method,
group.by = group.by,
ref.group = ref.group,
paired = paired,
symnum.args = symnum.args,
p.adjust.method = p.adjust.method) %>%
mutate("p.adj.method" = p.adjust.method))
statOut$p.adj.signif <- try(vapply(X = statOut$p.adj,
FUN = stats::symnum,
FUN.VALUE = "",
cutpoints = symnum.args$cutpoints,
symbols = symnum.args$symbols))
if (method %in% c("t.test", "wilcox.test")) {
statistics <- try(dplyr::left_join(statOut, d_max, by = group.by) %>%
dplyr::filter(.data$group1 %in% comparisons |
.data$group2 %in% comparisons) %>%
# Find max value (individual point or errorbar)
dplyr::mutate("max" = max(c(.data$max_value,
.data$max_error),
na.rm = TRUE)) %>%
dplyr::group_by_(group.by) %>%
dplyr::mutate(
"max_group" = max(c(.data$max_value,
.data$max_error),
na.rm = TRUE),
# Row number
"n" = dplyr::row_number(),
# First comparison group
"group1" = factor(.data$group1,
levels = levels(df[[comparison]])),
# Second comparison group
"group2" = factor(.data$group2,
levels = levels(df[[comparison]])),
# Adjustment of the height of the segment
"r" = dplyr::if_else(p == "p.signif" |
p == "p.adj.signif",
.data$max * 0.1 * 0.05,
.data$max * 0.2 * 0.05),
# Adjustment of the hieght of the stats
"e" = .data$max * .data$n * 0.05,
# Number of comparisons
"n_comps" = max(.data$n),
# Number of grouping variables
"group.by_n" = as.numeric(get(group.by)),
# Group number associated with first comparison group
"group1_n" = as.integer(.data$group1),
# Group number associated with second comparison group
"group2_n" = as.integer(.data$group2),
# Relative width of 1 bar
"unit" = (width / max(.data$group2_n)) *
dodge /
width,
# Center position of the first bar
"start" = .data$group.by_n -
.data$unit *
max(.data$group2_n) / 2,
# Center position of group1
"w.start" = .data$start +
(.data$group1_n - 1) *
.data$unit +
.data$unit /
2,
# Center position of group2
"w.stop" = .data$start +
(.data$group2_n - 1) *
.data$unit +
.data$unit / 2
) %>%
dplyr::ungroup() %>%
dplyr::mutate(
# Center of comparison line segment
"x.pos" = rowMeans(.[, c("w.start",
"w.stop")]),
# Update w.start if p.signif is.na()
"w.start" = ifelse(!is.na(.data$p.signif),
.data$w.start, NA),
# Update w.stop if p.signif is.na()
"w.stop" = ifelse(!is.na(.data$p.signif),
.data$w.stop, NA),
# Adjust height of stats
"h.p" = .data$max_group + .data$e,
# Adjust height of comparison line segment
"h.s" = .data$max_group + .data$e - .data$r
))
} else {
statistics <- try(dplyr::left_join(statOut, d_max, by = group.by) %>%
# Find max value (individual point or errorbar)
dplyr::mutate("max" = max(c(max_value, max_error),
na.rm = T)) %>%
dplyr::group_by_(group.by) %>%
dplyr::mutate(
"max_group" = max(c(.data$max_value,
.data$max_error),
na.rm = TRUE),
"n" = dplyr::row_number(),
"r" = dplyr::if_else(p == "p.signif" |
p == "p.adj.signif",
max * 0.1 * 0.05,
max * 0.2 * 0.05),
"e" = .data$max * .data$n * 0.05,
"n_comps" = max(.data$n),
"group.by_n" = as.numeric(get(group.by)),
"w.start" = .data$group.by_n -
width / length(unique(df[[comparison]])),
"w.stop" = .data$group.by_n +
width /
length(unique(df[[comparison]]))
) %>%
dplyr::ungroup() %>%
dplyr::mutate(
"x.pos" = rowMeans(.[, c("w.start", "w.stop")]),
# center of segment
"w.start" = ifelse(!is.na(.data$p.signif),
.data$w.start,
NA),
"w.stop" = ifelse(!is.na(.data$p.signif),
.data$w.stop,
NA),
"h.p" = .data$max_group + .data$e,
"h.s" = .data$max_group + .data$e - .data$r
))
}
if (("try-error" %in% class(statOut))) {
statistics <- dplyr::tibble("p.signif" = NA)
}
if (("try-error" %in% class(statistics))) {
statistics <- dplyr::tibble("p.signif" = NA)
}
if (stats) {
return(statOut)
}
# Specify y-axis limits
if (all(is.na(y.lim))) {
y.lim <-
c(0, max(d_max[, c("max_value", "max_error")], na.rm = TRUE) * 1.08)
}
if (!is.na(y.lim[1]) & is.na(y.lim[2])) {
y.lim <- c(y.lim[1], max(d_max[, c("max_value", "max_error")],
na.rm = TRUE) * 1.08)
}
if (!is.na(y.lim[2] & is.na(y.lim[1]))) {
y.lim <- c(0, y.lim[2])
}
# Adjust y limits if y transformation
# if (trans.y != "identity" & !all(is.na(statistics$p.signif))) {
# logBase <- readr::parse_number(trans.y)
# # statistics <- statistics %>%
# # dplyr::mutate("h.p" = .data$h.p * logBase,
# # "h.s" = .data$h.s * logBase)
#
# }
# If not specified by user, set y axis label to the variable being plotted.
if (is.null(y.lab)) {
y.lab <- unique(df$variable)
if (length(y.lab) > 1) {
y.lab <- y.lab[1]
}
}
# Make pretty scientific notation
max_e <- as.numeric(stringr::str_split(
string = format(max(c(
d_max$max_value,
d_max$max_error
)),
scientific = TRUE),
pattern = "e\\+"
)[[1]][2])
fancy_scientific <- function(l) {
l <- format(l, scientific = TRUE)
e <- as.numeric(vapply(l, function(a) {
stringr::str_split(a, pattern = "e\\+")[[1]][2]
}, ""))
e_dif <- as.numeric(vapply(e, function(x) {
(max_e - x)
}, numeric(1)))
l <- as.numeric(vapply(l, function(x) {
stringr::str_split(string = x, pattern = "e\\+")[[1]][1]
}, ""))
l2 <- c()
for (i in seq_len(length(e))) {
l2[i] <- ifelse(e[i] == 0, l[i],
ifelse(e[i] < max_e, (10 ^ -e_dif[i]) * l[i], l[i]))
}
format(l2, trim = FALSE)
}
if (angle.x) {
angle <- 45
vjust <- 1
hjust <- 1
} else {
angle <- 0
vjust <- 0
hjust <- 0.5
}
if (sci) {
labs.y <- fancy_scientific
y.lab <-
bquote(.(paste0(gsub(
"\\s*#\\s*", "", y.lab
), " "))(10 ^ .(max_e)))
} else {
labs.y <- ggplot2::waiver()
}
if (trans.y != "identity") {
assign("statistics", statistics, envir = globalenv())
.x <- NULL
if (trans.y == "log2") {
labs.y <- scales::trans_format(trans.y, scales::math_format(2 ^ .x))
} else {
labs.y <- scales::trans_format(trans.y, scales::math_format(10 ^ .x))
}
if (min(d_min$min, na.rm = TRUE) >= 0) {
y.lim <-
c(NA,
max(d_max[, c("max_value", "max_error")], na.rm = TRUE) * 1.08)
}
if (min(d_min$min, na.rm = TRUE) < 0) {
y.lim <-
c(NA,
max(d_max[, c("max_value", "max_error")], na.rm = TRUE) * 1.08)
}
}
# Assign names to the shape, fill, color, and alpha arguments
for (x in c("shape.groups", "fill.groups", "color.groups")) {
assign(x, stats::setNames(object = get(x), levels(df[[comparison]])))
}
# Create geoms
crossbar <- ggplot2::stat_summary(
ggplot2::aes(
group = get(comparison),
color = get(comparison)
),
fun.y = mean,
fun.ymax = mean,
fun.ymin = mean,
size = stroke / 3,
geom = "crossbar",
width = width,
position = ggplot2::position_dodge(dodge)
)
point <- ggplot2::geom_point(
ggplot2::aes(
shape = get(comparison),
color = get(comparison)
),
stroke = stroke,
size = size,
position = ggplot2::position_jitterdodge(jitter.width = 0.25,
dodge.width = dodge)
)
point_noJitter <- ggplot2::geom_point(
ggplot2::aes(
shape = get(comparison),
color = get(comparison)
),
stroke = stroke,
size = size,
position = ggplot2::position_dodge(dodge)
)
errorbar <-
ggplot2::stat_summary(
ggplot2::aes(group = get(comparison)),
fun.data = errortype,
fun.args = list(mult = 1),
geom = "errorbar",
color = "black",
width = 0.25 * width,
position = ggplot2::position_dodge(dodge),
size = stroke
)
bar <- ggplot2::stat_summary(
ggplot2::aes(fill = get(comparison)),
color = "black",
fun.y = mean,
size = stroke,
geom = "bar",
width = width,
position = ggplot2::position_dodge(dodge),
show.legend = TRUE
)
violin <- ggplot2::geom_violin(
ggplot2::aes(fill = get(comparison),
color = get(comparison)),
show.legend = TRUE,
position = ggplot2::position_dodge(dodge)
)
box <- ggplot2::geom_boxplot(
ggplot2::aes(color = get(comparison),
fill = get(comparison)),
show.legend = TRUE,
position = ggplot2::position_dodge(dodge)
)
line <- ggplot2::stat_summary(
ggplot2::aes(
group = get(comparison),
color = get(comparison)
),
fun.y = mean,
geom = "line",
size = stroke
)
line_error <-
ggplot2::stat_summary(
ggplot2::aes(group = get(comparison)),
fun.data = errortype,
fun.args = list(mult = 1),
geom = "errorbar",
color = "black",
width = 0.25 * width,
size = stroke
)
line_point <- ggplot2::stat_summary(
ggplot2::aes(
fill = get(comparison),
shape = get(comparison),
color = get(comparison)
),
stroke = stroke,
size = size,
fun.y = mean,
geom = "point"
)
dot <-
ggplot2::geom_dotplot(
ggplot2::aes(color = get(comparison)),
binaxis = "y",
stackdir = "center",
method = "histodot",
position = ggplot2::position_dodge(dodge)
)
density <- ggplot2::geom_density(ggplot2::aes(
color = get(comparison),
fill = get(comparison),
x = .data$value
),
inherit.aes = FALSE)
if (all(is.na(statOut$p.signif))) {
geom <- geom[which(!geom %in% c("stat", "seg"))]
} else {
stat <- ggplot2::geom_text(
data = statistics,
ggplot2::aes(.data$x.pos, stats::na.omit(.data$h.p)),
label = statistics[[p]],
size = font_size / (1 / 0.35),
inherit.aes = FALSE,
na.rm = TRUE
)
seg <- ggplot2::geom_segment(
data = statistics,
ggplot2::aes(
x = .data$w.start,
xend = .data$w.stop,
y = .data$h.s,
yend = .data$h.s
),
size = stroke,
inherit.aes = FALSE,
na.rm = TRUE
)
}
suppressWarnings(if ("line_point_stat" %in% geom) {
geom <- c("line", "line_error", "line_point", "stat")
})
suppressWarnings(if ("density" %in% geom) {
scale.x <-
ggplot2::scale_x_continuous(expand = c(0, 0), limits = x.lim)
y.lim <- c(0, NA)
})
# Create ggplot object and plot
g <- ggplot2::ggplot(data = df,
ggplot2::aes(x = get(group.by),
y = .data$value)) +
ggplot2::labs(
x = x.lab,
y = y.lab,
color = comparison,
shape = comparison,
fill = comparison,
alpha = comparison,
hjust = 0.5
) +
ggplot2::scale_y_continuous(
limits = y.lim,
expand = expand.y,
labels = labs.y,
trans = trans.y,
oob = scales::rescale_none
) +
scale.x +
ggplot2::scale_shape_manual(values = shape.groups) +
ggplot2::scale_fill_manual(values = fill.groups) +
ggplot2::scale_color_manual(values = color.groups) +
lapply(geom, function(x)
get(x)) +
ggplot2::theme(
line = ggplot2::element_line(colour = "black",
size = stroke),
text = ggplot2::element_text(size = font_size,
colour = "black"),
rect = ggplot2::element_blank(),
panel.grid = ggplot2::element_blank(),
legend.position = leg.pos,
legend.title = ggplot2::element_text(size = font_size,
colour = "black"),
legend.text = ggplot2::element_text(size = font_size,
colour = "black"),
axis.line.x = ggplot2::element_line(colour = "black", size = stroke),
axis.line.y = ggplot2::element_line(colour = "black", size = stroke),
axis.ticks.x = ggplot2::element_blank(),
axis.text.x = ggplot2::element_text(
size = font_size,
colour = "black",
angle = angle,
vjust = vjust,
hjust = hjust
),
axis.text = ggplot2::element_text(size = font_size,
colour = "black"),
plot.margin = ggplot2::margin(5, 0, 5, 0, "mm"),
legend.margin = ggplot2::margin(0, 0, 0, 0, "mm")
)
if (stats == FALSE) {
if (leg.pos %in% c("top", "bottom")) {
leg <- ggpubr::get_legend(g)
lwidth <- sum(as.numeric(grid::convertUnit(leg$width, "mm")))
} else {
lwidth <- 0
}
gt <- egg::set_panel_size(
g,
width = ggplot2::unit(plotWidth, "mm"),
height = ggplot2::unit(plotHeight, "mm")
)
gt$layout$clip[gt$layout$name == "panel"] <- "off"
# rect grobs such as those created by geom_bar() have "height" / "width"
# measurements, while point & text grobs have "y" / "x" measurements,
# & we look for both
max.grob.heights <- vapply(gt$grob[[which(
gt$layout$name == "panel")]]$children,
function(x)
ifelse(
!is.null(x$height) &
"unit" %in% class(x$height),
max(as.numeric(x$height), na.rm = TRUE),
ifelse(!is.null(x$y) &
"unit" %in% class(x$y),
max(as.numeric(x$y)),
0)
), numeric(1))
max.grob.heights <- max(max.grob.heights, na.rm = TRUE)
min.grob.heights <- vapply(gt$grob[[which(
gt$layout$name == "panel")]]$children,
function(x)
ifelse(
!is.null(x$height) &
"unit" %in% class(x$height),
min(as.numeric(x$height),
na.rm = TRUE),
ifelse(!is.null(x$y) &
"unit" %in% class(x$y),
min(as.numeric(x$y)),
0)
), numeric(1))
min.grob.heights <- min(min.grob.heights, na.rm = TRUE)
# identify panel row & calculate panel height
panel.row <- gt$layout[gt$layout$name == "panel", "t"] # = 7
panel.height <-
as.numeric(grid::convertUnit(gt$heights[panel.row], "mm"))
# calculate height of all the grobs above the panel
height.above.panel <- gt$heights[seq_len(panel.row - 1)]
height.above.panel <- sum(as.numeric(
grid::convertUnit(height.above.panel, "mm")), na.rm = TRUE)
# check whether the out-of-bound object (if any) exceeds this height,
# & replace if necessary
if (max.grob.heights > 1) {
oob.height.above.panel <- (max.grob.heights - 1) * panel.height
height.above.panel <-
max(height.above.panel, oob.height.above.panel,
na.rm = TRUE)
}
# as above, calculate the height of all the grobs below the panel
height.below.panel <-
gt$heights[(panel.row + 1):length(gt$heights)]
height.below.panel <- sum(as.numeric(
grid::convertUnit(height.below.panel, "mm")), na.rm = TRUE)
# as above
if (min.grob.heights < 0) {
oob.height.below.panel <- abs(min.grob.heights) * panel.height
height.below.panel <-
max(height.below.panel, oob.height.below.panel,
na.rm = TRUE)
}
# sum the result
pheight <-
height.above.panel + panel.height + height.below.panel
gt <- gtable::gtable_add_padding(gt,
padding = ggplot2::unit(c(
height.above.panel,
lwidth / 2,
5,
lwidth / 2
), "mm"))
return(gt)
}
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.