В настоящее время я учусь писать геометрию сам, так что это будет довольно длинный и бессвязный пост, поскольку я прохожу свои мыслительные процессы, распутывая аспекты геометрии (создание многоугольников и сегментов линий) от аспектов статистики (вычисляя, где эти многоугольники & сегменты должны быть) геом.
Отказ от ответственности: я не знаком с такого рода сюжетами, и Google не предоставил много авторитетных руководств. Возможно, я не понимаю, как рассчитывается / используется доверительный интервал.
Шаг 0. Определите взаимосвязь между геометрией / статистикой и функцией слоя.
geom_boxplot и stat_boxplot являются примерами функций уровня. Если вы введете их в консоль R, вы увидите, что они (относительно) короткие и не содержат фактического кода для расчета поля / усов на диаграмме. Вместо этого geom_boxplot содержит строку с надписью geom = GeomBoxplot, а stat_boxplot содержит строку с надписью stat = StatBoxplot (воспроизведено ниже).
> stat_boxplot
function (mapping = NULL, data = NULL, geom = "boxplot", position = "dodge2",
..., coef = 1.5, na.rm = FALSE, show.legend = NA, inherit.aes = TRUE)
{
layer(data = data, mapping = mapping, stat = StatBoxplot,
geom = geom, position = position, show.legend = show.legend,
inherit.aes = inherit.aes, params = list(na.rm = na.rm,
coef = coef, ...))
}
GeomBoxplot и StatBoxplot являются объектами ggproto. Именно там творится волшебство.
Шаг 1. Примите во внимание, что параметр ggproto() _inherit - ваш друг.
Не изобретайте велосипед. Поскольку мы хотим создать что-то, что хорошо перекрывается с диаграммой, мы можем взять ссылку из Geom / Stat используется для этого и меняет только то, что необходимо.
StatMeanDiamonds <- ggproto(
`_class` = "StatMeanDiamonds",
`_inherit` = StatBoxplot,
... # add functions here to override those defined in StatBoxplot
)
GeomMeanDiamonds <- ggproto(
`_class` = "GeomMeanDiamonds",
`_inherit` = GeomBoxplot,
... # as above
)
Шаг 2. Измените статистику.
В StatBoxplot определены 3 функции: setup_data, setup_params и compute_group. Вы можете обратиться к коду на Github (ссылка выше) для получения подробной информации или просмотреть их, введя, например, StatBoxplot$compute_group.
Функция compute_group вычисляет значения ymin / lower / middle / upper / ymax для всех значений y, связанных с каждой группой (т. Е. Каждого уникального значения x), которые используются для построения прямоугольной диаграммы. Мы можем заменить его тем, который вместо этого вычисляет доверительный интервал и средние значения:
# ci is added as a parameter, to allow the user to specify different confidence intervals
compute_group_new <- function(data, scales, width = NULL,
ci = 0.95, na.rm = FALSE){
a <- mean(data$y)
s <- sd(data$y)
n <- sum(!is.na(data$y))
error <- qt(ci + (1-ci)/2, df = n-1) * s / sqrt(n)
stats <- c("lower" = a - error, "mean" = a, "upper" = a + error)
if(length(unique(data$x)) > 1) width <- diff(range(data$x)) * 0.9
df <- as.data.frame(as.list(stats))
df$x <- if(is.factor(data$x)) data$x[1] else mean(range(data$x))
df$width <- width
df
}
(Необязательно) StatBoxplot позволяет пользователю включать weight в качестве эстетического сопоставления. Мы также можем учесть это, заменив:
a <- mean(data$y)
s <- sd(data$y)
n <- sum(!is.na(data$y))
с участием:
if(!is.null(data$weight)) {
a <- Hmisc::wtd.mean(data$y, weights = data$weight)
s <- sqrt(Hmisc::wtd.var(data$y, weights = data$weight))
n <- sum(data$weight[!is.na(data$y) & !is.na(data$weight)])
} else {
a <- mean(data$y)
s <- sd(data$y)
n <- sum(!is.na(data$y))
}
Нет необходимости изменять другие функции в StatBoxplot. Итак, мы можем определить StatMeanDiamonds следующим образом:
StatMeanDiamonds <- ggproto(
`_class` = "StatMeanDiamonds",
`_inherit` = StatBoxplot,
compute_group = compute_group_new
)
Шаг 3. Измените геометрию.
GeomBoxplot имеет 3 функции: setup_data, draw_group и draw_key. Он также включает определения для default_aes() и required_aes().
Поскольку мы изменили исходный источник данных (данные, созданные StatMeanDiamonds, содержат вычисляемые столбцы «нижний» / «средний» / «верхний»), тогда как данные, созданные StatBoxplot, будут содержать вычисляемые столбцы «ymin» / «нижний» / "средний" / "верхний" / "ymax"), проверьте, затронута ли также нисходящая функция setup_data. (В этом случае GeomBoxplot$setup_data не ссылается на затронутые столбцы, поэтому никаких изменений здесь не требуется.)
Функция draw_group берет данные, созданные StatMeanDiamonds и настроенные setup_data, и создает несколько фреймов данных. "common" содержит эстетические сопоставления, общие для всех геометрий. «diamond.df» для сопоставлений, которые вносят вклад в ромбовидный многоугольник, и «segment.df» для сопоставлений, которые вносят вклад в горизонтальный линейный сегмент в среднем. Затем кадры данных передаются draw_panel функциям GeomPolygon и GeomSegment соответственно для создания фактических сегментов полигонов / линий.
draw_group_new = function(data, panel_params, coord,
varwidth = FALSE){
common <- data.frame(colour = data$colour,
size = data$size,
linetype = data$linetype,
fill = alpha(data$fill, data$alpha),
group = data$group,
stringsAsFactors = FALSE)
diamond.df <- data.frame(x = c(data$x, data$xmax, data$x, data$xmin),
y = c(data$upper, data$mean, data$lower, data$mean),
alpha = data$alpha,
common,
stringsAsFactors = FALSE)
segment.df <- data.frame(x = data$xmin, xend = data$xmax,
y = data$mean, yend = data$mean,
alpha = NA,
common,
stringsAsFactors = FALSE)
ggplot2:::ggname("geom_meanDiamonds",
grid::grobTree(
GeomPolygon$draw_panel(diamond.df, panel_params, coord),
GeomSegment$draw_panel(segment.df, panel_params, coord)
))
}
Функция draw_key используется для создания легенды для этого слоя, если в этом возникнет необходимость. Поскольку GeomMeanDiamonds наследуется от GeomBoxplot, значение по умолчанию - draw_key = draw_key_boxplot, и мы не должны его изменять. Если оставить его без изменений, код не будет нарушен. Однако я думаю, что более простая легенда, такая как draw_key_polygon, предлагает менее загроможденный вид.
Характеристики default_aes GeomBoxplot выглядят нормально. Но нам нужно изменить required_aes, поскольку данные, которые мы ожидаем получить от StatMeanDiamonds, отличаются («нижний» / «средний» / «верхний» вместо «ymin» / «нижний» / «средний» / «верхний» / «ymax» ").
Теперь мы готовы определить GeomMeanDiamonds:
GeomMeanDiamonds <- ggproto(
"GeomMeanDiamonds",
GeomBoxplot,
draw_group = draw_group_new,
draw_key = draw_key_polygon,
required_aes = c("x", "lower", "upper", "mean")
)
Шаг 4. Определите функции слоя.
Это скучная часть. Я скопировал напрямую из geom_boxplot / stat_boxplot, удалив все ссылки на выбросы в geom_meanDiamonds, изменив на geom = GeomMeanDiamonds / stat = StatMeanDiamonds и добавив ci = 0.95 в stat_meanDiamonds.
geom_meanDiamonds <- function(mapping = NULL, data = NULL,
stat = "meanDiamonds", position = "dodge2",
..., varwidth = FALSE, na.rm = FALSE, show.legend = NA,
inherit.aes = TRUE){
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 = GeomMeanDiamonds, position = position,
show.legend = show.legend, inherit.aes = inherit.aes,
params = list(varwidth = varwidth, na.rm = na.rm, ...))
}
stat_meanDiamonds <- function(mapping = NULL, data = NULL,
geom = "meanDiamonds", position = "dodge2",
..., ci = 0.95,
na.rm = FALSE, show.legend = NA, inherit.aes = TRUE) {
layer(data = data, mapping = mapping, stat = StatMeanDiamonds,
geom = geom, position = position, show.legend = show.legend,
inherit.aes = inherit.aes,
params = list(na.rm = na.rm, ci = ci, ...))
}
Шаг 5. Проверьте вывод.
# basic
ggplot(iris,
aes(Species, Sepal.Length)) +
geom_boxplot() +
geom_meanDiamonds()
# with additional parameters, to see if they break anything
ggplot(iris,
aes(Species, Sepal.Length)) +
geom_boxplot(width = 0.8) +
geom_meanDiamonds(aes(fill = Species),
color = "red", alpha = 0.5, size = 1,
ci = 0.99, width = 0.3)
person
Z.Lin
schedule
28.09.2018
