Это не то, что я действительно сделал бы без лота оправдания, поскольку люди обычно ожидают, что значения min / max / box бокса соответствуют тем же квантильным позициям, но это можно сделать.
Используемые данные (с экстремальными значениями, добавленными для демонстрации выбросов):
set.seed(12)
u <- data.frame(A = sample.int(4, 100, replace = TRUE), B = rnorm(100))
u$B[c(30, 70, 76)] <- c(4, -4, -5)
Решение 1 : Вы можете предварительно вычислить значения, не переходяпо основному маршруту R, и включить расчеты для выбросов в том же шаге.Я сделал бы это полностью в библиотеках Tidyverse Хэдли, которые я нахожу более точными:
library(dplyr)
library(tidyr)
u %>%
group_by(A) %>%
summarise(lower = quantile(B, qlower),
upper = quantile(B, qupper),
middle = quantile(B, qmiddle),
IQR = diff(c(lower, upper)),
ymin = max(quantile(B, qymin), lower - 1.5 * IQR),
ymax = min(quantile(B, qymax), upper + 1.5 * IQR),
outliers = list(B[which(B > upper + 1.5 * IQR |
B < lower - 1.5 * IQR)])) %>%
ungroup() %>%
ggplot(aes(x = A)) +
geom_boxplot(aes(lower = lower, upper = upper,
middle = middle, ymin = ymin, ymax = ymax ),
stat="identity") +
geom_point(data = . %>%
filter(sapply(outliers, length) > 0) %>%
select(A, outliers) %>%
unnest(),
aes(y = unlist(outliers)))
Решение 2 : Выможет переопределить фактические спецификации квантилей, используемые ggplot.Расчеты для квантилей geom_boxplot() в действительности выполняются в функции StatBoxplot compute_group(), найденной здесь :
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))
}
... (omitted for space)
Вектор qs определяет позиции квантиля.На него не влияют параметры, переданные в compute_group(), поэтому единственный способ изменить это изменить само определение compute_group():
# save a copy of the original function, in case you need to revert
original.function <- environment(ggplot2::StatBoxplot$compute_group)$f
# define new function (only the first line for qs is changed, but you'll have to
# copy & paste the whole thing)
new.function <- function (data, scales, width = NULL, na.rm = FALSE, coef = 1.5) {
qs <- c(0.1, 0.2, 0.5, 0.8, 0.9)
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[2] - coef * iqr) | data$y > (stats[4] +
coef * iqr)
if (any(outliers)) {
stats[c(1, 5)] <- range(c(stats[2:4], data$y[!outliers]),
na.rm = TRUE)
}
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
}
Результат:
# toggle between the two definitions
environment(StatBoxplot$compute_group)$f <- original.function
ggplot(u, aes(x = A, y = B, group = A)) +
geom_boxplot() +
ggtitle("original definition for calculated quantiles")
environment(StatBoxplot$compute_group)$f <- new.function
ggplot(u, aes(x = A, y = B, group = A)) +
geom_boxplot() +
ggtitle("new definition for calculated quantiles")
Обратите внимание, что при изменении определения это влияет на каждый объект ggplot в вашей среде.Таким образом, если вы создали объект коробочного графика ggplot до изменения определения, и распечатали его после , блокплот будет следовать новому определению.(Для сравнения, приведенного выше, мне пришлось немедленно преобразовать каждый ggplot в объект grob, чтобы сохранить разницу.)