Добавление среднего к geom_de density_ridges

Нанесение горизонтальных линий

Если я правильно понимаю, OP хочет построить горизонтальную линию в месте, где плотность равна средней плотности для каждой из линий гребня.

Выражение

density_lines <- ingredients %>%
  group_by(group) %>% filter(density == mean(density)) %>% ungroup()

возвращает пустой набор данных, поскольку нет записи, в которой значение density в точности совпадает с mean(density).

Однако он работает для общего максимума (но не для всех локальных максимумов).

density_lines <- ingredients %>%
  group_by(group) %>% filter(density == max(density)) %>% ungroup()

который дает

Найдите ближайшее значение

Поскольку нет точного совпадения, ближайшее значение может быть выбрано

density_lines <- ingredients %>%
  group_by(group) %>% 
  top_n(1, -abs(density - mean(density))) 

который строится как

Это строит один сегмент на каждую линию гребня, но мы ожидаем увидеть 4 сегмента в каждой из ветвей кривой (те, где максимум соседнего пика больше среднего). С участием

density_lines <- ingredients %>%
  group_by(group) %>% 
  top_n(4, -abs(density - mean(density))) 

мы получаем

Вы можете поиграть с параметром n на top_n(), но, IMHO, правильным способом было бы сгруппировать каждую линию гребня от пика к долине и от впадины к пику, чтобы получить один сегмент для каждой ветви кривой.

Найдите ценность поблизости

В качестве альтернативы мы можем отфильтровать с помощью функции near(). Эта функция требует указать допуск tol, который нам нужно вычислить из набора данных:

density_lines <- ingredients %>%
  group_by(group) %>% 
  filter(near(
    density, mean(density), 
    tol = ingredients %>% summarise(0.25 * max(abs(diff(density)))) %>% pull()
  )) 

Для тщательно подобранного коэффициента 0.25 (попытка и ошибка) получаем

РЕДАКТИРОВАТЬ: построение вертикальных линий

Похоже, я неверно истолковал намерения ОП. Теперь мы попытаемся построить вертикальную линию в точке mean(density), используя geom_hline (с coord_flip(), geom_hline() создает вертикальную линию).

Опять же, мы следуем умному подходу OP для извлечения плотностей и масштабных коэффициентов из созданного графика.

# create plot object
Fig1 <- ggplot(Figure3Data,  aes(x = hairchange, y = EffortGroup)) +
  geom_density_ridges_gradient(aes(fill = ..x..), scale = 0.9, size = 1) +
  scale_fill_gradientn(
    colours = c("#0000FF", "#FFFFFF", "#FF0000"),
    name =
      NULL,
    limits = c(-2, 2)
  ) + coord_flip() +
  theme_ridges(
    font_size = 20,
    grid = TRUE,
    line_size = 1,
    center_axis_labels = TRUE
  ) +
  scale_x_continuous(name = 'Average Self-Perceived Hair Change', limits =
                       c(-2, 2)) +
  ylab('Total SSM Effort (hours)')

# extract plot data and summarise
mean_density <- 
  ggplot_build(Fig1) %>% 
  purrr::pluck("data", 1) %>%
  group_by(group) %>% 
  summarise(density = mean(density), scale = first(scale), iscale = first(iscale))

# add hline and plot
Fig1 +
  geom_hline(aes(yintercept = group + density * scale * iscale),
             data = mean_density)

РЕДАКТИРОВАТЬ 2. Постройте горизонтальные линии в позиции среднего самооценки изменения волос.

OP пояснил, что

Я хочу, чтобы это было среднее самооцененное изменение волос (данные оси Y) для каждой из 10 линий гребня.

Этого можно добиться, выполнив следующие действия:

1. Создайте объект ridgeplot.
2. Вычислите среднее самооценку изменения волос для каждого EffortGroup.
3. Выберите значения созданных значений плотности из данных графика.
4. Присоединяйтесь к обоим наборам данных.
5. Вычислите значения плотности в местах расположения средних, используя approx()
6. Нарисуйте отрезки линии.

Среднее самооценка изменения волос для каждого EffortGroup рассчитывается с помощью

Figure3Data %>% 
  group_by(EffortGroup) %>% 
  summarise(x_mean = mean(hairchange))

что дает (для опубликованного подмножества данных OP):

  EffortGroup x_mean
  <chr>        <dbl>
1 <5          -0.643
2 12.5        -0.143

Все шаги вместе:

# create plot object
Fig1 <- ggplot(Figure3Data,  aes(x = hairchange, y = EffortGroup)) +
  geom_density_ridges_gradient(aes(fill = ..x..), scale = 0.9, size = 1) +
  scale_fill_gradientn(
    colours = c("#0000FF", "#FFFFFF", "#FF0000"),
    name = NULL,
    limits = c(-2, 2)) + 
  coord_flip() +
  theme_ridges(
    font_size = 20,
    grid = TRUE,
    line_size = 1,
    center_axis_labels = TRUE) +
  scale_x_continuous(name = 'Average Self-Perceived Hair Change', 
                     limits = c(-2, 2)) +
  ylab('Total SSM Effort (hours)')

density_lines <-
  Figure3Data %>% 
  group_by(EffortGroup) %>% 
  summarise(x_mean = mean(hairchange)) %>% 
  mutate(group = as.integer(factor(EffortGroup))) %>% 
  left_join(ggplot_build(Fig1) %>% purrr::pluck("data", 1), 
            on = "group") %>% 
  group_by(group) %>%
  summarise(x_mean = first(x_mean), 
            density = approx(x, density, first(x_mean))$y, 
            scale = first(scale), 
            iscale = first(iscale))

# add segments and plot
Fig1 +
  geom_segment(aes(x = x_mean,
                   y = group,
                   xend = x_mean,
                   yend = group + density * scale * iscale),
               data = density_lines)

РЕДАКТИРОВАТЬ 3: изменить порядок горизонтальной оси

OP попросил изменить заказ горизонтальную ось соответственно. Это можно сделать, предварительно переведя EffortGroup из типа character в factor, где уровни факторов явно указаны в ожидаемом порядке:

# turn EffortGroup into factor with levels in desired order
lvls <- c("<5", "12.5", "22.5", "35", "50", "75", "105", "152", "210", "210+")
Figure3Data <- 
  Figure3Data %>% 
  mutate(EffortGroup = factor(EffortGroup, levels = lvls))

В качестве альтернативы EffortGroup может быть получено непосредственно из заданных Effort значений с помощью

# create Effort Group from scratch
lvls <- c("<5", "12.5", "22.5", "35", "50", "75", "105", "152", "210", "210+")
brks <- c(-Inf, 5, 12.5, 22.5, 35, 50, 75, 105, 152, 210, Inf)
Figure3Data <- 
  Figure3Data %>% 
  mutate(EffortGroup = cut(Effort, brks, lvls, right = FALSE))

В любом случае, необходимо изменить вычисление density_lines, поскольку EffortGroup уже является фактором:

density_lines <-
  Figure3Data %>% 
  group_by(EffortGroup) %>% 
  summarise(x_mean = mean(hairchange)) %>% 
  mutate(group = as.integer(EffortGroup)) %>%   # remove call to factor() here
  left_join( ...

С полным набором данных, предоставленным OP (ссылка), график наконец становится

Местоположение среднего самооценки изменения волос для каждого EffortGroup дается выражением

Figure3Data %>% 
  group_by(EffortGroup) %>% 
  summarise(x_mean = mean(hairchange)) 

# A tibble: 10 x 2
   EffortGroup  x_mean
   <fct>         <dbl>
 1 <5          -0.643 
 2 12.5        -0.393 
 3 22.5        -0.118 
 4 35          -0.0606
 5 50           0.286 
 6 75           0     
 7 105          0.152 
 8 152          0.167 
 9 210          0.379 
10 210+         0.343