#' Function bp
#'
#' Custom barplot with labeled bars.
#' @param x Numeric vector, matrix or data.frame containing the values to be displayed.
#' @param sd Numeric vector, matrix or data.frame of same format as x containing standard deviations.
#' @param cex Size of axis fonts. Defaults to 1.
#' @param beside Logical value indicating if bars should be placed next to each other. Defaults to T.
#' @param horiz Logical value indicating if bars should be placed horizontal. Defaults to F.
#' @param breakLabels Logical value indicating if labels of bars should be tranformed by quantqual::labelbreaker. Defaults to F.
#' @param add.numbers Logical value indicating if numbers should be placed above bars. Defaults to F.
#' @param ndigits Numeric value specifying the number of digits to be plotted (if add.numbers==T). Defaults to 2.
#' @param ncex Size of fonts. If NA (default) is set to cex.
#' @param nsrt Numeric value specifying the rotation of the numbers (between 0 and 360 degrees). Defaults to 0.
#' @param npos Numeric value specifying the position of numbers. If NA (default) it is determined automatically.
#' @param ncol Vector containing the color of bars. Defaults to "black".
#' @param sdcol Vector containing the color of arrows. Defaults to "grey".
#' @param grid Logical value indicating whether to plot a grid. Defaults to T.
#' @param plot Logical value indicating whether to plot the barplot. Defaults to T.
#' @param main Character vector with one element containing the barplot's title. Defaults to NULL
#' @param sub Character vector with one element containing the barplot's subtitle. Defaults to NULL
#' @param xlim.factor Numeric value for adding extra space to the right of the barplot (if a legend is provided). Defaults to 1.5
#' @param xlim Numeric vector containing xlim.
#' @param las Numeric value specifying the rotation of the y-axis (0 for 90 percent rotation, 1 for 0 percent rotation). Defaults to 1.
#' @param srt Numeric value specifying the rotation of the x-axis (between 0 and 360 degrees). Defaults to 45.
#' @param names.arg Character vector containing names of bars. If NULL (default) colnames of x will be applied as names.arg.
#' @param legend.text Legend text. Set to NA or to F to supress legend. If NULL (default) rownames of x will be applied as legend.text.
#' @param optimize.legend Logical or character value. If T (Default), the legend is shifted to the right if overlapping with bars (as long as no args.legend are provided). If a position is provided instead ("bottom", "bottomleft", "left","topleft","top","topright","right","bottomright") the legend will be placed and shifted accordingly. Adding a "1" at the end of a position (e.g., "top1") results in the legend being drawn horizontally instead of vertically.
#' @param args.legend List with arguments to pass to legend(). Defaults to list(bg = "white").
#' @param density Vector giving the density of shading lines, in lines per inch, for the bars or bar components. The default value of NULL means that no shading lines are drawn. Non-positive values of density also inhibit the drawing of shading lines.
#' @param angle Slope of shading lines, given as an angle in degrees (counter-clockwise), for the bars or bar components.
#' @param col Vector containing the color of bars. If NULL (default) colors are generated based on the rainbow-palette.
#' @param grid.col Character or rgb value containing the color of grid lines. Defaults to "grey".
#' @param axes Logical value indicating whether to plot axes. Defaults to T.
#' @param add Logical value indicating whether to plot the barplot to the current device. Defaults to F.
#' @param adj Numeric value between 0 and 1, indicating where to plot main title and axis labels - if any - between left (0) and right (1). Defaults to 0.5
#' @param default.labels Logical value, indicating whether to use traditional barplot-labels (which, e.g., hide in case of overlap) instead of bp-style labels. Defaults to F.
#' @param xlab Character value representing the label to be drawn next to the x-axis. Defaults to NA.
#' @param ylab Character value representing the label to be drawn next to the y-axis. Defaults to NA.
#' @param border Color of the bars' border. Defaults to NA.
#' @param grid.mode Numeric value specifying when to plot the grid. 0 for grid in the background, 1 for grid in the foreground. Defaults to 0.
#' @param ... Additional graphical parameters for barplot.
#' @details Plots a barplot and adds labels and numbers to bars. Optionally allows for plotting standard deviations around each bar.
#' @keywords plotting
#' @export
#' @examples
#' bp(data.frame(group1=c(variable1=1,variable2=2),group2=c(variable1=3,variable2=4)),horiz=T,main="Example")
bp <- function (x = NULL, sd = NULL, cex = 1, beside = T, horiz = F,
breakLabels = F, add.numbers = F, ndigits = 2, ncex = NA,
nsrt = 0, npos = NA, ncol = "black", sdcol = "grey", grid = T,
plot = T, main = NULL, sub = NULL, xlim.factor = 1.5, las = 1,
srt = 45, xlim = NULL, ylim = NULL, names.arg = NULL, legend.text = NULL,
optimize.legend = T, args.legend = NULL, density = NULL,
angle = 45, col = NULL, grid.col = "grey", axes = T, add = F,
adj = 0.5, default.labels = F, xlab = NA, ylab = NA, border = NA,
grid.mode = 0, main1 = NULL, main2 = NULL, main3 = NULL,
adj.main1 = 0, adj.main2 = 0, adj.main3 = 0, col.main1 = "black",
col.main2 = "black", col.main3 = "black", cex.main1 = 1.2,
cex.main2 = 1.2, cex.main3 = 1.2, font.main1 = 1, font.main2 = 2,
font.main3 = 4, omitZeros = T, mar = NA, automar = F, ...)
{
addChars = ifelse(is.character(add.numbers), add.numbers,
"")
mar0 = NULL
if (is.character(add.numbers))
add.numbers = T
if (is.null(ncex))
ncex = cex
else if (is.na(ncex))
ncex = cex
if (!is.null(npos))
if (is.na(npos))
if (beside == T)
npos = ifelse(horiz == T, 4, 3)
else npos = NULL
if (is.null(x))
x = data.frame(test1 = c(1, 2, 3), test2 = c(2, 3, 4))
else if (is.table(x)) {
y = matrix(sapply(x, as.numeric), nrow = dim(x)[1])
if (length(dim(x)) == 1) {
rownames(y) = names(x)
}
else {
rownames(y) = rownames(x)
colnames(y) = colnames(x)
}
x = y
}
el = list(...)
x = as.matrix(x)
if (is.character(x))
stop("Please provide numeric data!")
x2 = ifelse(dim(x)[2] == 1 & beside == T, list(x[, 1]), list(x))[[1]]
if (!is.null(sd)) {
sd = ifelse(dim(x)[2] == 1, list(as.matrix(sd)[, 1]),
list(as.matrix(sd)))[[1]]
}
if (is.null(rownames(x)))
rownames(x) = 1:dim(x)[1]
if (is.null(colnames(x)))
colnames(x) = 1:dim(x)[2]
if (is.matrix(x2)) {
rownames(x2) = rownames(x)
colnames(x2) = colnames(x)
}
else names(x2) = rownames(x)
width = unlist(ifelse(length(el[["width"]]) > 0, el["width"],
list(1))[[1]])
space = unlist(ifelse(length(el[["space"]]) > 0, el["space"],
ifelse(beside & dim(x)[2] > 1, list(c(0, 1)), list(0.2)))[[1]])
if (is.null(col))
col = rainbow(dim(x)[1])
if (is.null(legend.text) & dim(x)[2] > 1)
legend.text = rownames(x)
if (!is.null(legend.text))
if (sum(is.na(legend.text)) > 0)
legend.text = NULL
else if (length(legend.text) == 1)
if (legend.text[[1]] == F)
legend.text = NULL
if (length(args.legend) == 1)
if (sum(is.na(args.legend)) > 0 | sum(args.legend ==
F) > 0)
legend.text = NULL
if (is.null(xlim))
if (!horiz) {
b = barplot(x2, beside = beside, horiz = horiz, plot = F,
add = add, ...)
xlim = c(min(b) - (width[1]/2), max(b) + (width[1]/2))
if (!is.null(legend.text))
xlim[2] = xlim[2] * xlim.factor
}
else {
if (beside) {
xlim = c(min(c(min(x), 0)), max(c(max(x), 0)))
}
else {
xlim = c(min(c(min(colSums(x)), 0)), max(c(max(colSums(x)),
0)))
}
if (!is.null(legend.text))
xlim[2] = xlim[2] * xlim.factor
}
if (is.null(ylim))
if (!horiz) {
if (beside) {
ylim = c(min(c(min(x), 0)), max(c(max(x), 0)))
}
else {
ylim = c(min(c(min(colSums(x)), 0)), max(c(max(colSums(x)),
0)))
}
}
else {
b = barplot(x2, beside = beside, horiz = horiz, plot = F,
add = add, ...)
ylim = c(min(b) - (width[1]/2), max(b) + (width[1]/2))
}
if (!is.null(names.arg)) {
if (length(names.arg) == 1)
if (is.na(names.arg))
names.arg = rep(NA, dim(x)[2])
if (dim(x)[2] == 1)
rownames(x) = names.arg
else colnames(x) = names.arg
}
else names.arg = ifelse(dim(x)[2] == 1, list(rownames(x)),
list(colnames(x)))[[1]]
if (automar)
mar = ifelse(horiz, list(quantqual::mar(labels2 = names.arg)),
list(quantqual::mar(labels1 = names.arg)))[[1]]
if (is.numeric(mar)) {
mar0 = par("mar")
par(mar = mar)
}
b = NULL
if (grid.mode == 0) {
b = as.matrix(barplot(x2, beside = beside, horiz = horiz,
density = density, angle = angle, xlim = xlim, ylim = ylim,
plot = plot, las = las, add = add, adj = adj, main = main,
sub = sub, col = NA, xlab = xlab, ylab = ylab, border = NA,
axes = F, names.arg = ifelse(default.labels == T,
list(names.arg), list(rep(NA, dim(x)[2])))[[1]],
...))
}
else {
b = as.matrix(barplot(x2, border = border, xlab = xlab,
ylab = ylab, names.arg = ifelse(default.labels ==
T, list(names.arg), list(rep(NA, dim(x)[2])))[[1]],
beside = beside, horiz = horiz, density = density,
angle = angle, col = col, xlim = xlim, ylim = ylim,
main = main, sub = sub, plot = plot, las = las, axes = F,
add = add, adj = adj, ...))
}
abline2 = function(xl, xlf, ...) {
xaxp <- ifelse((length(dev.list()) > 0 | plot == T),
list(par("xaxp")), list(c(0, 1, 5)))[[1]]
yaxp <- ifelse((length(dev.list()) > 0 | plot == T),
list(par("yaxp")), list(c(0, 1, 5)))[[1]]
segments(x0 = min(xl), y0 = seq(yaxp[1], yaxp[2], (yaxp[2] -
yaxp[1])/yaxp[3]), x1 = max(xl)/xlf, y1 = seq(yaxp[1],
yaxp[2], (yaxp[2] - yaxp[1])/yaxp[3]), ...)
}
abline3 = function(xl, xlf, ...) {
xaxp <- ifelse((length(dev.list()) > 0 | plot == T),
list(par("xaxp")), list(c(0, 1, 5)))[[1]]
yaxp <- ifelse((length(dev.list()) > 0 | plot == T),
list(par("yaxp")), list(c(0, 1, 5)))[[1]]
segments(y0 = min(xl), x0 = seq(xaxp[1], xaxp[2], (xaxp[2] -
xaxp[1])/xaxp[3]), y1 = max(xl)/xlf, x1 = seq(xaxp[1],
xaxp[2], (xaxp[2] - xaxp[1])/xaxp[3]), ...)
}
if (plot != F)
if (!horiz) {
if (grid != F)
abline2(xlim, ifelse(!is.null(legend.text), xlim.factor,
1), col = grid.col)
}
else {
if (grid != F)
abline3(ifelse((length(dev.list()) > 0 | plot ==
T), list(par("usr")), list(c(0, 1, 0, 1)))[[1]][3:4],
1, col = grid.col)
}
if (grid.mode == 0 & plot != F)
b = as.matrix(barplot(x2, border = border, xlab = NA,
ylab = NA, names.arg = rep(NA, dim(x)[2]), beside = beside,
horiz = horiz, density = density, angle = angle,
col = col, xlim = xlim, ylim = ylim, main = NA, sub = NA,
plot = plot, las = las, axes = F, add = T, adj = adj,
...))
if (plot != F)
if (!is.null(sd) & beside)
if (!horiz) {
arrows(b, x2 + sd, b, x2 - sd, angle = 90, code = 3,
length = 0.1, xpd = T, col = sdcol)
}
else {
arrows(x2 + sd, b, x2 - sd, b, angle = 90, code = 3,
length = 0.1, xpd = T, col = sdcol)
}
if (beside == T) {
rownames(b) = rownames(x)
colnames(b) = colnames(x)
}
else {
rownames(b) = colnames(x)
}
b2 = ifelse(dim(b)[2] == 1, list(t(b)), list(as.matrix(b)))[[1]]
x0 = min(xlim) - 0.05 * (max(xlim) - min(xlim))
y0 = min(ylim) - 0.05 * (max(ylim) - min(ylim))
if (plot != F) {
round2 = function(x, ndigits, addChars = "") {
x2 = as.character(round(x, digits = ndigits))
x2[is.na(x)] = ""
if (omitZeros == T)
x2[x2 == 0] = ""
x2 = paste0(x2, addChars)
x2[x2 == addChars] = ""
return(x2)
}
if (breakLabels == T)
colnames(b2) = quantqual::labelbreaker(colnames(b2))
if (is.numeric(breakLabels))
colnames(b2) = quantqual::labelbreaker(colnames(b2),
breakLabels[1])
if (!horiz) {
if (axes != F) {
xaxp <- ifelse((length(dev.list()) > 0 | plot ==
T), list(par("xaxp")), list(c(0, 1, 5)))[[1]]
yaxp <- ifelse((length(dev.list()) > 0 | plot ==
T), list(par("yaxp")), list(c(0, 1, 5)))[[1]]
s <- seq(yaxp[1], yaxp[2], (yaxp[2] - yaxp[1])/yaxp[3])
axis(2, s, paste0(s, addChars))
}
if (default.labels != T)
text(colMeans(b2), y0, colnames(b2), srt = srt,
pos = ifelse((srt == 0 | srt == 180 | srt ==
360), 1, 2), xpd = T, cex = cex)
if (add.numbers)
if (beside) {
text(b, x, round2(x, ndigits, addChars), pos = npos,
col = ncol, cex = ncex, srt = nsrt, xpd = T)
}
else {
text(b, x[1, ]/2, round2(x[1, ], ndigits, addChars),
col = ncol, xpd = T, cex = ncex, srt = nsrt,
pos = npos)
if (dim(x)[1] > 1)
for (i in 2:dim(x)[1]) {
m = as.matrix(x[c(1:i), ])
dim(m) = c(length(c(1:i)), dim(x)[2])
text(b, ifelse(dim(x)[2] == 1, list((sum(rbind(m[1:i,
])) + sum(rbind(m[1:(i - 1), ])))/2),
list((colSums(rbind(m[1:i, ])) + colSums(rbind(m[1:(i -
1), ])))/2))[[1]], labels = round2(x[i,
], ndigits, addChars), col = ncol, xpd = T,
cex = ncex, srt = nsrt, pos = npos)
}
}
}
else {
if (axes != F) {
xaxp <- ifelse((length(dev.list()) > 0 | plot ==
T), list(par("xaxp")), list(c(0, 1, 5)))[[1]]
yaxp <- ifelse((length(dev.list()) > 0 | plot ==
T), list(par("yaxp")), list(c(0, 1, 5)))[[1]]
s <- seq(xaxp[1], xaxp[2], (xaxp[2] - xaxp[1])/xaxp[3])
axis(1, s, paste0(s, addChars))
}
if (default.labels != T)
text(x0, colMeans(b2), colnames(b2), srt = srt -
45, pos = 2, xpd = T, cex = cex)
if (add.numbers)
if (beside) {
text(x, b, round2(x, ndigits, addChars), pos = npos,
col = ncol, cex = ncex, srt = nsrt, xpd = T)
}
else {
text(x[1, ]/2, b, round2(x[1, ], ndigits, addChars),
col = ncol, xpd = T, cex = ncex, srt = nsrt,
pos = npos)
if (dim(x)[1] > 1)
for (i in 2:dim(x)[1]) {
m = as.matrix(x[c(1:i), ])
dim(m) = c(length(c(1:i)), dim(x)[2])
text(ifelse(dim(x)[2] == 1, list((sum(rbind(m[1:i,
])) + sum(rbind(m[1:(i - 1), ])))/2),
list((colSums(rbind(m[1:i, ])) + colSums(rbind(m[1:(i -
1), ])))/2))[[1]], b, labels = round2(x[i,
], ndigits, addChars), col = ncol, xpd = T,
cex = ncex, srt = nsrt, pos = npos)
}
}
}
}
if (plot != F)
if (is.numeric(mar))
par(mar = mar0)
xy <- c(min(xlim), max(xlim), min(ylim), max(ylim))
if (plot != F)
if (!is.null(legend.text)) {
if (is.null(args.legend)) {
if (optimize.legend != F & !is.null(optimize.legend) &
!is.na(optimize.legend)) {
legend.text[grep("[^ \n\r]$", legend.text)] = paste0(legend.text[grep("[^ \n\r]$",
legend.text)], " ")
if (optimize.legend == T) {
xl1 = xy[2L] - xinch(0.1)
yl1 = xy[4L] - yinch(0.1)
xjust = 1
yjust = 1
}
if (optimize.legend == "topright" | optimize.legend ==
"topright1") {
xl1 = xy[2L] - xinch(0.1)
yl1 = xy[4L] - yinch(0.1)
xjust = 1
yjust = 1
}
if (optimize.legend == "top" | optimize.legend ==
"top1") {
xl1 = (xy[2L] + xy[1L])/2
yl1 = xy[4L] - yinch(0.1)
xjust = 0.5
yjust = 1
}
if (optimize.legend == "topleft" | optimize.legend ==
"topleft1") {
xl1 = xy[1L] + xinch(0.1)
yl1 = xy[4L] - yinch(0.1)
xjust = 0
yjust = 1
}
if (optimize.legend == "left" | optimize.legend ==
"left1" | optimize.legend == "left2") {
xl1 = xy[1L] + xinch(0.1)
yl1 = (xy[3L] + xy[4L])/2
xjust = 0
yjust = 0.5
}
if (optimize.legend == "bottomleft" | optimize.legend ==
"bottomleft1") {
xl1 = xy[1L] + xinch(0.1)
yl1 = xy[3L] + yinch(0.1)
xjust = 0
yjust = 0
}
if (optimize.legend == "bottom" | optimize.legend ==
"bottom1" | optimize.legend == "bottom2") {
xl1 = (xy[2L] + xy[1L])/2
yl1 = xy[3L] + yinch(0.1)
xjust = 0.5
yjust = 0
}
if (optimize.legend == "bottomright" | optimize.legend ==
"bottomright1") {
xl1 = xy[2L] - xinch(0.1)
yl1 = xy[3L] + yinch(0.1)
xjust = 1
yjust = 0
}
if (optimize.legend == "right" | optimize.legend ==
"right1") {
xl1 = xy[2L] - xinch(0.1)
yl1 = (xy[3L] + xy[4L])/2
xjust = 1
yjust = 0.5
}
if (optimize.legend == "center" | optimize.legend ==
"center1") {
xl1 = (xy[2L] + xy[1L])/2
yl1 = (xy[3L] + xy[4L])/2
xjust = 0.5
yjust = 0.5
}
l = legend(x = xl1, y = yl1, plot = F, horiz = (length(grep("1$",
optimize.legend)) > 0), bg = "white", legend = legend.text,
angle = angle, density = density, fill = col,
xjust = xjust, yjust = yjust)
xl2 = xl1 + l$rect$w
yl2 = yl1 - l$rect$h
xbr = ifelse(horiz == T, ifelse(beside == T,
max(x2, na.rm = T), max(colSums(x2, na.rm = T),
na.rm = T)), max(b, na.rm = T) + (width[1]/2))
xbl = ifelse(optimize.legend == "left2", 0 +
x0, ifelse(horiz == T, min(c(x2, 0), na.rm = T),
min(b, na.rm = T) - (width[1]/2)))
ybt = ifelse(horiz == F, ifelse(beside == T,
max(x2, na.rm = T), max(colSums(x2, na.rm = T),
na.rm = T)), max(b, na.rm = T) + (width[1]/2))
ybb = ifelse(optimize.legend == "bottom2",
0 + y0, ifelse(horiz == F, min(c(x2, 0),
na.rm = T), min(b, na.rm = T) - (width[1]/2)))
xl1 = l$rect$left
xl2 = xl1 + l$rect$w
yl1 = l$rect$top
yl2 = yl1 - l$rect$h
if (length(grep("right", optimize.legend)) >
0 | optimize.legend == T) {
xl1 = ifelse(xl1 < xbr, xbr + xinch(0.1),
xl1)
xl2 = xl1 + l$rect$w
}
else if (length(grep("left2", optimize.legend)) >
0) {
xl1 = ifelse(xl2 > xbl, xbl - l$rect$w -
xinch(ifelse(horiz == T, 0.47, 0.3)), xl1)
xl2 = xl1 + l$rect$w
}
else if (length(grep("left", optimize.legend)) >
0) {
xl1 = ifelse(xl2 > xbl, xbl - l$rect$w -
xinch(0.1), xl1)
xl2 = xl1 + l$rect$w
}
else if (length(grep("top", optimize.legend)) >
0) {
yl1 = ifelse(yl2 < ybt, ybt - yinch(0.1),
yl1)
yl2 = yl1 - l$rect$h
}
else if (length(grep("bottom2", optimize.legend)) >
0) {
yl1 = ifelse(yl1 > ybb, ybb - yinch(ifelse(horiz ==
T, 0.47, 0.3)), yl1)
yl2 = yl1 - l$rect$h
}
else if (length(grep("bottom", optimize.legend)) >
0) {
yl1 = ifelse(yl1 > ybb, ybb - yinch(0.1),
yl1)
yl2 = yl1 - l$rect$h
}
legend(x = c(xl1, xl2), y = c(yl1, yl2), plot = T,
xpd = T, horiz = (length(grep("1$", optimize.legend)) >
0), bg = "white", legend = legend.text,
angle = angle, density = density, fill = col,
xjust = xjust, yjust = yjust)
}
else {
legend(x = xy[2L] - xinch(0.1), y = xy[4L] -
yinch(0.1), bg = "white", legend = legend.text,
angle = angle, density = density, fill = col,
xjust = 1, yjust = 1)
}
}
else {
args.legend1 <- list(x = xy[2L] - xinch(0.1),
y = xy[4L] - yinch(0.1), bg = "white", legend = legend.text,
angle = angle, density = density, fill = col,
xjust = 1, yjust = 1)
args.legend1[names(args.legend)] <- args.legend
do.call("legend", args.legend1)
}
}
if (plot != F) {
if (!is.null(main1))
title(main1, line = 1, adj = adj.main1, cex.main = cex.main1,
col = col.main1, font.main = font.main1)
if (!is.null(main2))
title(main2, line = 2, adj = adj.main2, cex.main = cex.main2,
col = col.main2, font.main = font.main2)
if (!is.null(main3))
title(main3, line = 3, adj = adj.main3, cex.main = cex.main3,
col = col.main3, font.main = font.main3)
}
return(invisible(b))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.