Related
I have a plot made with ggplot where the legends adds extra black points to all the other legends (see image).
library(tidyverse)
library(ggnewscale)
set.seed(12345)
brks = c(0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 1)
fd = expand.grid(x = seq(6,16, length.out = 100),
y = seq(6,18, length.out = 100))
fd$z = sample(x = seq(0,1, length.out = 100), size = nrow(fd), replace = T)
df.t = data.frame(s = LETTERS[1:5], l = c(11,12,8,15,14), d = c(13,10,7,16,8))
mypal = data.frame(A = "black", B = "red",C = "blue", D = "green", E = "yellow")
summmmmmmm = expand.grid(s = LETTERS[1:5],
yr = 1995:2012)
summmmmmmm$yr = as.factor(summmmmmmm$yr)
summmmmmmm$l = NA
summmmmmmm$d = NA
summmmmmmm[summmmmmmm$s == "A","l"] = rnorm(n = 18, mean = 11, sd = .5)
summmmmmmm[summmmmmmm$s == "B","l"] = rnorm(n = 18, mean = 12, sd = .5)
summmmmmmm[summmmmmmm$s == "C","l"] = rnorm(n = 18, mean = 8, sd = .5)
summmmmmmm[summmmmmmm$s == "D","l"] = rnorm(n = 18, mean = 15, sd = .5)
summmmmmmm[summmmmmmm$s == "E","l"] = rnorm(n = 18, mean = 14, sd = .5)
summmmmmmm[summmmmmmm$s == "A","d"] = rnorm(n = 18, mean = 13, sd = .5)
summmmmmmm[summmmmmmm$s == "B","d"] = rnorm(n = 18, mean = 10, sd = .5)
summmmmmmm[summmmmmmm$s == "C","d"] = rnorm(n = 18, mean = 8, sd = .5)
summmmmmmm[summmmmmmm$s == "D","d"] = rnorm(n = 18, mean = 16, sd = .5)
summmmmmmm[summmmmmmm$s == "E","d"] = rnorm(n = 18, mean = 9, sd = .5)
ggplot(data = fd, mapping = aes(x = x, y = y, z = z)) +
geom_contour_filled(breaks = brks)+
geom_point(data = df.t,
mapping = aes(x = l, y = d, color = s), inherit.aes = FALSE, size = 5) +
scale_fill_manual(values = alpha(hcl.colors(100, "YlOrRd", rev = TRUE, alpha = 1), .99))+
scale_color_manual(values = alpha(mypal,1),
name = "obj")+
new_scale_color() +
geom_point(data = summmmmmmm,
mapping = aes(x = l, y = d,
color = yr, group = s),
shape = 19,
inherit.aes = FALSE,
show.legend = TRUE) +
geom_path(data = summmmmmmm[order(summmmmmmm$yr),],
mapping = aes(x = l, y = d, color = yr,
group = as.factor(s)), inherit.aes = FALSE,
show.legend = FALSE) +
scale_color_viridis_d(name = "time")
I'd like to get rid of those extra points. Also, I like the 'time' legend to be in 2 columns, but not the other legends. Is there a way to do this?
You need to use guide = guide_legend(ncol = 2) in your viridis scale to get two columns.
You can set show.legend = c(colour = TRUE, fill = FALSE) in the second point layer, to specifically show the legend in colour scales but not in fill scales.
See example below (where I've renamed summmmmmmm to df for my own sanity)
ggplot(data = fd, mapping = aes(x = x, y = y, z = z)) +
geom_contour_filled(breaks = brks)+
geom_point(
data = df.t,
mapping = aes(x = l, y = d, color = s), inherit.aes = FALSE, size = 5
) +
scale_fill_manual(
values = alpha(hcl.colors(100, "YlOrRd", rev = TRUE, alpha = 1), .99)
)+
scale_color_manual(values = alpha(mypal,1), name = "obj")+
new_scale_color() +
geom_point(
data = df,
mapping = aes(x = l, y = d, color = yr, group = s),
shape = 19, inherit.aes = FALSE,
show.legend = c(colour = TRUE, fill = FALSE)
) +
geom_path(
data = df[order(df$yr),],
mapping = aes(x = l, y = d, color = yr, group = as.factor(s)),
inherit.aes = FALSE, show.legend = FALSE
) +
scale_color_viridis_d(name = "time", guide = guide_legend(ncol = 2))
The correlation plot has significant symbols and numbers are overlapped. Does anyone know how to locate the significant symbol below the number?
cor <- Hmisc::rcorr(mtcars %>% as.matrix())
corrplot::corrplot(cor$r, method="color", tl.cex = 1, tl.col = "black", number.cex = 0.8,
p.mat = cor$P, sig.level = c(.001, .01, .05), insig = 'label_sig',
pch = 10, pch.cex = 1, pch.col = "white", type = "lower", tl.srt = 45,
addCoef.col = "black", addgrid.col = "white", cl.pos = "n",
fn_left=135, fn_up = 20,
cl.lim=c(-1, 1))
ggplot2 may provide more flexibility
library(ggplot2)
nm = rownames(cor$r)
m = t(combn(nm, 2))
d = cbind(data.frame(m), R = cor$r[m], P = cor$P[m])
d$label = round(d$R, 2)
d$label[d$P < 0.001] = paste0(d$label[d$P < 0.001], "\n**")
d$X1 = factor(d$X1, nm)
d$X2 = factor(d$X2, rev(nm))
graphics.off()
ggplot(d, aes(X1, X2, fill = R, label = label)) +
geom_tile(color = "white") +
scale_fill_viridis_c() +
geom_text(color = ifelse(d$R > 0.35, "black", "white")) +
theme_bw() +
coord_equal()
I am trying to automate the process of plotting data using ggplot and the facet_wrap functionality. I want a single y-axis label instead individual plot Ob (i.e., A_Ob, B_ob etc) and also a single X-axis not all the plots having label for x-axis such as below. Below is my sample code using gridextra package. However, i would like to do it through facet_wrap as i have many other plots to draw which i think will save me sometime.
graphics.off()
rm(list = ls())
library(tidyverse)
library(gridExtra)
G1 = data.frame(A_Ob = runif(1000, 5, 50), A_Sim = runif(1000, 3,60), A_upper = runif(1000, 10,70), A_lower = runif(1000, 0, 45 ),
B_Ob = runif(1000, 5, 50), B_Sim = runif(1000, 3,60), B_upper = runif(1000, 10,70), B_lower = runif(1000, 0, 45 ),
C_Ob = runif(1000, 5, 50), C_Sim = runif(1000, 3,60), C_upper = runif(1000, 10,70), C_lower = runif(1000, 0, 45 ),
D_Ob = runif(1000, 5, 50), D_Sim = runif(1000, 3,60), D_upper = runif(1000, 10,70), D_lower = runif(1000, 0, 45 ),
Pos = 1:1000)
A1 = ggplot(data = G1, aes(x = Pos))+
geom_line(aes(y = A_Ob), col = "black")+
geom_line(aes(y = A_Sim), col = "blue")+
geom_vline(xintercept = 750, color = "red", size=1.5)+
geom_ribbon(aes(ymin = A_upper, ymax = A_lower), fill = "grey70")
B1 = ggplot(data = G1, aes(x = Pos))+
geom_line(aes(y = B_Ob), col = "black")+
geom_line(aes(y = B_Sim), col = "blue")+
geom_vline(xintercept = 750, color = "red", size=1.5)+
geom_ribbon(aes(ymin = B_upper, ymax = B_lower), fill = "grey70")
C1 = ggplot(data = G1, aes(x = Pos))+
geom_line(aes(y = C_Ob), col = "black")+
geom_line(aes(y = C_Sim), col = "blue")+
geom_vline(xintercept = 750, color = "red", size=1.5)+
geom_ribbon(aes(ymin = C_upper, ymax = C_lower), fill = "grey70")
D1 = ggplot(data = G1, aes(x = Pos))+
geom_line(aes(y = D_Ob), col = "black")+
geom_line(aes(y = D_Sim), col = "blue")+
geom_vline(xintercept = 750, color = "red", size=1.5)+
geom_ribbon(aes(ymin = D_upper, ymax = D_lower), fill = "grey70")
grid.arrange(A1,B1,C1,D1, nrow = 4)
Here is the result of the code
You need to reshape your dataframe into a longer format and separate values for Ob, Sim, upper and lower.
Using the function melt from data.table package can help you to achieve this:
library(data.table)
setDT(G1)
Ob_cols = grep("_Ob",colnames(G1),value = TRUE)
Sim_cols = grep("_Sim",colnames(G1),value = TRUE)
Upper_cols = grep("_upper",colnames(G1), value = TRUE)
Lower_cols = grep("_lower", colnames(G1), value = TRUE)
g.m <- melt(G1, measure = list(Ob_cols,Sim_cols,Upper_cols,Lower_cols), value.name = c("OBS","SIM","UP","LOW"))
levels(g.m$variable) <- c("A","B","C","D")
Pos variable OBS SIM UP LOW
1: 1 A 5.965488 29.167666 26.66783 29.97259
2: 2 A 23.855719 8.570245 43.75830 30.65616
3: 3 A 16.947887 51.201047 15.20758 39.76122
4: 4 A 49.883306 3.715319 34.38066 20.73177
5: 5 A 5.021938 3.102880 30.05036 32.05123
6: 6 A 19.887176 15.400853 53.67156 28.54982
and now, you can plot it:
library(ggplot2)
ggplot(g.m, aes(x = Pos))+
geom_line(aes(y = OBS), color = "black")+
geom_line(aes(y = SIM), color = "blue")+
geom_vline(xintercept = 750,color = "red", size = 1.5)+
geom_ribbon(aes(ymin = UP, ymax = LOW), fill = "grey70")+
facet_grid(variable~.)
EDIT: Adding annotations & renaming labels
To rename and replace facet labels, you can re-define levels of variable and use facet_wrap instead of facet_grid using ncol = 1 as argument.
To add multiple annotations on a single panel, you need to define a dataframe that you will use in geom_text.
Altogether, you have to do:
# renaming names of each facets:
levels(g.m$variable) <- c("M1","M2","M3","M4")
# Defining annotations to add:
df_text <- data.frame(label = c("Calibration", "Validation"),
x = c(740,760),
y = c(65,65),
hjust = c(1,0),
variable = factor("M1", levels = c("M1","M2","M3","M4")))
# Plotting
ggplot(g.m, aes(x = Pos))+
geom_line(aes(y = OBS), color = "black")+
geom_line(aes(y = SIM), color = "blue")+
geom_vline(xintercept = 750,color = "red", size = 1.5)+
geom_ribbon(aes(ymin = UP, ymax = LOW), fill = "grey70")+
facet_wrap(variable~., ncol = 1)+
theme(strip.text.x = element_text(hjust = 0),
strip.background = element_rect(fill = "white"))+
geom_text(data = df_text, aes(x = x, y = y, label = label, hjust = hjust), color = "red")
Does it look what you are expecting ?
I have made some graphics using doubleYscale command from latticeExtra. I'd like to reduce or even completely remove the white space between the vertical axes and coloured area -I mean, I want data lines to start and end immediatly next to axes-.
My script is like this:
# -----------------------------------------------------------------------------#
library("xts") ## se usa para manipular y graficar series temporales
library("lubridate") ## se usa para manipular fechas
library("lattice") ## se usa para graficar las series
library("latticeExtra") ## se usa para pintar áreas en los gráficos
# -----------------------------------------------------------------------------#
fechas <- seq(as.Date('2017-05-22'), length.out = 365, by = 'days')
serie.0 <- xts::xts(x = runif(n = length(fechas)), order.by = fechas)
serie.5 <- xts::xts(x = runif(n = length(fechas)), order.by = fechas)
titulo <- list(label = 'Título', col = 'black', cex = 1.2)
umbrales.y <- c(0, 0.1, 0.3, 0.5, 0.7, 0.9, 1, 1.1)
etiq.der <- c("PMP", "10%AU", "30%AU", "50%AU", "70%AU", "90%AU", "CC", "")
marcas.x <- fechas[which(day(fechas) == 1)]
labels.x <- substr(as.character(month(marcas.x, label = T)), 1, 3)
scales.x <- list(at = marcas.x + 15, tck = 0, labels = labels.x, cex = 1.1, rot = 0, col = "black")
scales.y <- list(at = umbrales.y, col = "black", rot = 0, labels = c())
scales.y.der <- list(at = umbrales.y, rot = 0, col = "black", labels = etiq.der)
plot.0 <- lattice::xyplot(serie.0 ~ fechas, panel = function(x, y) {
panel.xyarea(x, y = umbrales.y[8], col = "cadetblue",
border = NULL)
panel.xyarea(x, y = umbrales.y[7], col = "darkgreen",
border = NULL)
panel.xyarea(x, y = umbrales.y[6], col = "green4",
border = NULL)
panel.xyarea(x, y = umbrales.y[5], col = "chartreuse3",
border = NULL)
panel.xyarea(x, y = umbrales.y[4], col = "darkolivegreen1",
border = NULL)
panel.xyarea(x, y = umbrales.y[3], col = "lightgoldenrod1",
border = NULL)
panel.xyarea(x, y = umbrales.y[2], col = "chocolate3",
border = NULL)
panel.xyarea(x, y = umbrales.y[1], col = "brown4",
border = NULL)
panel.abline(v = marcas.x, col = "darkgrey",
lwd = 0.05)
panel.abline(h = umbrales.y[4], col = "black",
lwd = 2)
panel.xyplot(x, y, type = "l", col = "darkblue",
lwd = 2)},
xlab = NULL,
ylab = list('Almacenaje', cex = 1, col = 'black'),
main = titulo,
ylim = c(- 0.1, 1),
xlim = range(fechas),
scales = list(relation = "free", col = "black", x = scales.x, y = scales.y),
key = list(text = list(c("Último año", "Decil 5")),
lines = list(col = c("darkblue", "black"),
lty = c(1,2), lwd = c(2,1.9))),
par.settings = list(simpleTheme(col = 1),
layout.widths = list(ylab.axis.padding = -3)))
plot.1 <- lattice::xyplot(serie.5 ~ fechas, type = "l",
col = "black", lwd = 1.9, lty = 2,
ylim = c(- 0.1, 1),
xlim = range(fechas),
scales = list(relation = "free", x = scales.x, y = scales.y.der))
#png(filename = 'C:/Eugenia/graf.png', width = 600, height = 480)
print(latticeExtra::doubleYScale(plot.0, plot.1, style1 = 0, style2 = 0))
#dev.off()
An the result:
I've tried changing the layout.widths parameters, but didn't find the way.
Thank you in advance for any help!
This question is related to How to change boxplot settings when stat_summary is used, where I managed to build nice unicolor boxplots.
However, due to the "unicolor", the median segment's colour cannot be distinguished from the rest of the box. I've managed to add a black point for the median, but I prefer to add a segment instead. Here is the code:
# Data
xdf2 <- data.frame(month = rep(1:6, each = 100),
grp = rep(c('A','B'), 50*6))
xdf2$m <- rpois(n = nrow(xdf2),10)
# Definition of whiskers
f <- function(x) {
r <- quantile(x, probs = c(0.10, 0.25, 0.5, 0.75, 0.90))
names(r) <- c("ymin", "lower", "middle", "upper", "ymax")
r
}
# Add points outside of whiskers
o <- function(x) {
subset(x, x < quantile(x, probs=0.1) | quantile(x, probs=0.9) < x)
}
# Plot
ggplot(data = xdf2, aes(factor(month), m, colour = grp, fill = grp)) +
stat_summary(fun.data = f, geom="boxplot",
position = position_dodge(width=1), size = 2) +
stat_summary(fun.y = o, geom="point",
position = position_dodge(width = 1)) +
scale_color_manual(values = c("indianred","orange"), labels = c("AAA", "BBB")) +
scale_fill_manual(values = c("indianred", "orange"), labels = c("AAA", "BBB")) +
theme_bw() +
stat_summary(fun.y = "median", geom = "point",
position = position_dodge(width = 1), col = "black", size = 4)
And here is the graph:
I would like to add a segment by building a function which compute the parameters for geom="segment":
# Add function to compute segment parameters
s <- function(x,y,z) {
x2 <- x - z
y2 <- median(y)
x2end <- x + z
y2end <- median(y)
# assemble the named output
out <- c(x = x2, y = y2, xend = x2end, yend = y2end)
names(out) <- c("x","y","xend","yend")
out
}
and replace the geom="point" part with:
stat_summary(fun.y = s(month, m, 0.3), geom = "segment",
position = position_dodge(width = 1), col="black")
What I get is:
Error in s(month, m, 0.3) (from #2) : object 'month' not found
If I could better understand the logic of stat_summary, I could solve this problem. But I find it's not easy. If somebody could help me to solve this problem with stat_summary and geom = "segment", I would be very glad and maybe I will understand better the logic behind.
I would also appreciate alternative solutions for adding a horizontal line to mark the median.
There are so many pieces to a boxplot that it's probably worth the effort to change the underlying ggproto object, rather than recreate outliers / whiskers / boxes / median segments piece by piece, & hope they still stack well together.
Here's the result:
# Data
set.seed(123)
xdf2 <- data.frame(month = rep(1:6,each=100), grp = rep(c('A','B'), 50*6))
xdf2$m <- rpois(n=nrow(xdf2),10)
p <- ggplot(data = xdf2,
aes(factor(month), m, colour = grp, fill = grp)) +
scale_color_manual(values = c("A" = "indianred", "B" = "orange"),
labels = c("A" = "AAA", "B" = "BBB"),
aesthetics = c("color", "fill")) +
theme_bw() +
theme(legend.position = "bottom")
p +
geom_boxplot2(position = position_dodge(width = 1), size = 2,
qs = c(0.10, 0.25, 0.5, 0.75, 0.90),
median.colour = "black")
Here are some more variations with different aesthetic options:
library(dplyr)
cowplot::plot_grid(
p +
labs(subtitle = paste("quantiles = c(0.05, 0.3, 0.5, 0.7, 0.95)",
"median segment color = brown",
sep = "\n")) +
geom_boxplot2(position = position_dodge(width = 0.8), size = 2,
qs = c(0.05, 0.3, 0.5, 0.7, 0.95),
median.colour = "brown"),
p %+% filter(xdf2, !(month == 2 & grp == "B")) +
labs(subtitle = paste("some data missing",
"position = dodge2, preserve = single",
sep = "\n")) +
geom_boxplot2(position = position_dodge2(preserve = "single"), size = 2,
qs = c(0.10, 0.25, 0.5, 0.75, 0.90),
median.colour = "black"),
p %+% filter(xdf2, !(month == 2 & grp == "B")) +
labs(subtitle = paste("some data missing",
"position = dodge, preserve = single",
sep = "\n")) +
geom_boxplot2(position = position_dodge(preserve = "single"), size = 2,
qs = c(0.10, 0.25, 0.5, 0.75, 0.90),
median.colour = "black"),
nrow = 1
)
Code:
# define stat_boxplot2() based on stat_boxplot, but with boxplot quantiles (qs)
# added as a parameter (default values are same as original function), &
# stat = StatBoxplot2 instead of StatBoxplot
stat_boxplot2 <- function (
mapping = NULL, data = NULL, geom = "boxplot", position = "dodge2",
..., coef = 1.5, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
qs = c(0, 0.25, 0.5, 0.75, 1)) {
layer(data = data, mapping = mapping, stat = StatBoxplot2,
geom = geom, position = position, show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(na.rm = na.rm,
coef = coef,
qs = qs, ...))
}
# define StatBoxplot2 based on StatBoxplot, with compute_group function tweaked
# to use qs passed from stat_boxplot2(), & outlier definition simplified to
# include all data points beyond the range of qs values
StatBoxplot2 <- ggproto(
"StatBoxplot2", StatBoxplot,
compute_group = function(data, scales, width = NULL, na.rm = FALSE, coef = 1.5,
qs = c(0, 0.25, 0.5, 0.75, 1)) {
if (!is.null(data$weight)) {
mod <- quantreg::rq(y ~ 1, weights = weight, data = data,
tau = qs)
stats <- as.numeric(stats::coef(mod))
}
else {
stats <- as.numeric(stats::quantile(data$y, qs))
}
names(stats) <- c("ymin", "lower", "middle", "upper", "ymax")
iqr <- diff(stats[c(2, 4)])
outliers <- data$y < stats[1] | data$y > stats[5] # change outlier definition
if (length(unique(data$x)) > 1)
width <- diff(range(data$x)) * 0.9
df <- as.data.frame(as.list(stats))
df$outliers <- list(data$y[outliers])
if (is.null(data$weight)) {
n <- sum(!is.na(data$y))
}
else {
n <- sum(data$weight[!is.na(data$y) & !is.na(data$weight)])
}
df$notchupper <- df$middle + 1.58 * iqr/sqrt(n)
df$notchlower <- df$middle - 1.58 * iqr/sqrt(n)
df$x <- if (is.factor(data$x))
data$x[1]
else mean(range(data$x))
df$width <- width
df$relvarwidth <- sqrt(n)
df
}
)
# define geom_boxplot2() based on geom_boxplot, using stat = "boxplot2" by
# default instead of "boxplot", with a new parameter median.colour, &
# geom = GeomBoxplot2 instead of GeomBoxplot
geom_boxplot2 <- function(mapping = NULL, data = NULL, stat = "boxplot2", position = "dodge2",
..., outlier.colour = NULL, outlier.color = NULL, outlier.fill = NULL,
outlier.shape = 19, outlier.size = 1.5, outlier.stroke = 0.5,
outlier.alpha = NULL, notch = FALSE, notchwidth = 0.5, varwidth = FALSE,
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE,
median.colour = NULL, median.color = NULL) {
if (is.character(position)) {
if (varwidth == TRUE)
position <- position_dodge2(preserve = "single")
}
else {
if (identical(position$preserve, "total") & varwidth ==
TRUE) {
warning("Can't preserve total widths when varwidth = TRUE.",
call. = FALSE)
position$preserve <- "single"
}
}
layer(data = data, mapping = mapping, stat = stat, geom = GeomBoxplot2,
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(outlier.colour = outlier.color %||% outlier.colour,
outlier.fill = outlier.fill, outlier.shape = outlier.shape,
outlier.size = outlier.size, outlier.stroke = outlier.stroke,
outlier.alpha = outlier.alpha, notch = notch, notchwidth = notchwidth,
varwidth = varwidth, na.rm = na.rm,
median.colour = median.color %||% median.colour, ...))
}
# define GeomBoxplot2 based on GeomBoxplot, with draw_group function & draw_key
# functions tweaked to use median.colour for the median segment's colour, if available
GeomBoxplot2 <- ggproto(
"GeomBoxplot2",
GeomBoxplot,
draw_group = function (data, panel_params, coord, fatten = 2, outlier.colour = NULL,
outlier.fill = NULL, outlier.shape = 19, outlier.size = 1.5,
outlier.stroke = 0.5, outlier.alpha = NULL, notch = FALSE,
notchwidth = 0.5, varwidth = FALSE, median.colour = NULL) {
common <- data.frame(colour = data$colour, size = data$size,
linetype = data$linetype, fill = alpha(data$fill, data$alpha),
group = data$group, stringsAsFactors = FALSE)
whiskers <- data.frame(x = data$x, xend = data$x,
y = c(data$upper, data$lower),
yend = c(data$ymax, data$ymin),
alpha = NA,
common, stringsAsFactors = FALSE)
box <- data.frame(xmin = data$xmin, xmax = data$xmax, ymin = data$lower,
y = data$middle, ymax = data$upper,
ynotchlower = ifelse(notch, data$notchlower, NA),
ynotchupper = ifelse(notch,
data$notchupper, NA),
notchwidth = notchwidth, alpha = data$alpha,
common, stringsAsFactors = FALSE)
if (!is.null(data$outliers) && length(data$outliers[[1]] >= 1)) {
outliers <- data.frame(y = data$outliers[[1]], x = data$x[1],
colour = outlier.colour %||% data$colour[1], fill = outlier.fill %||%
data$fill[1], shape = outlier.shape %||% data$shape[1],
size = outlier.size %||% data$size[1], stroke = outlier.stroke %||%
data$stroke[1], fill = NA, alpha = outlier.alpha %||%
data$alpha[1], stringsAsFactors = FALSE)
outliers_grob <- GeomPoint$draw_panel(outliers, panel_params,
coord)
}
else {
outliers_grob <- NULL
}
if(is.null(median.colour)){
ggplot2:::ggname(
"geom_boxplot",
grobTree(outliers_grob,
GeomSegment$draw_panel(whiskers, panel_params, coord),
GeomCrossbar$draw_panel(box, fatten = fatten, panel_params, coord)))
} else {
ggplot2:::ggname(
"geom_boxplot",
grobTree(outliers_grob,
GeomSegment$draw_panel(whiskers, panel_params, coord),
GeomCrossbar$draw_panel(box, fatten = fatten, panel_params, coord),
GeomSegment$draw_panel(transform(box, x = xmin, xend = xmax, yend = y,
size = size, alpha = NA,
colour = median.colour),
panel_params,
coord)))
}
},
draw_key = function (data, params, size) {
if(is.null(params$median.colour)){
draw_key_boxplot(data, params, size)
} else {
grobTree(linesGrob(0.5, c(0.1, 0.25)),
linesGrob(0.5, c(0.75, 0.9)),
rectGrob(height = 0.5, width = 0.75),
linesGrob(c(0.125, 0.875), 0.5,
gp = gpar(col = params$median.colour)),
gp = gpar(col = data$colour,
fill = alpha(data$fill, data$alpha),
lwd = data$size * .pt,
lty = data$linetype))
}
}
)