Наложить теоретическое нормальное распределение на мои реальные данные

Question

У меня есть несколько диаграмм, которые отображают логарифмическое нормальное распределение sh некоторых данных о доходах. Я хотел наложить теоретическое нормальное распределение слоем / фоном, чтобы подчеркнуть любой перекос или разницу между моей логической нормальной попыткой сделать распределение нормальным и фактическим нормальным распределением. Пример кода:

library(ggplot2)
library(dplyr)

f <- function(x) {
   y <- diamonds$price[diamonds$cut == x]
   paste(seq(-3, 3), scales::dollar(round(mean(y) + seq(-3, 3) * sd(y))), sep = "\n")
}

breaks <- as.vector(sapply(levels(diamonds$cut), f))

diamonds %>% 
    group_by(cut) %>% 
    mutate(z = scale(price) + 3 + 1000 * as.numeric(cut)) %>%
    ggplot(aes(z)) +
    geom_point(aes(x = z - 2, y = 1), alpha = 0) +
    geom_density() +
    scale_x_continuous(breaks =  as.vector(sapply(1:5 * 1000, "+", 0:6)), 
                       labels = breaks) +
    facet_wrap(vars(cut), scales = "free_x") +
  theme(text = element_text(size = 16),
        axis.text.x = element_text(size = 6))

Выглядит так: введите описание изображения здесь

В этом случае цена на бриллианты $ визуально не соответствует логике. Есть ли способ наложить теоретическое нормальное распределение на каждую диаграмму?

Answer 1

Вы можете создать второй фрейм данных, который представляет собой (смещенные) нормальные плотности при каждом разрезе, а затем добавить его с помощью geom_line. Функция crossing взята из пакета tidyr и создает перекрестное соединение между двумя фреймами данных компонентов:

library(ggplot2)
library(dplyr)
library(tidyr)

f <- function(x) {
  y <- diamonds$price[diamonds$cut == x]
  paste(seq(-3, 3), scales::dollar(round(mean(y) + seq(-3, 3) * sd(y))), sep = "\n")
}

breaks <- as.vector(sapply(levels(diamonds$cut), f))

x <- seq(-3, 3, length.out = 1000)

shifted_densities <- data.frame(
  cut = levels(diamonds$cut),
  mean = seq(1000, 5000, length.out = 5) + 3) %>% # group means based on your breaks
  crossing(
    data.frame(x = x, 
               p = dnorm(x))) %>%
  mutate(x = x + mean) # shift everything over to the right center

diamonds %>% 
  group_by(cut) %>% 
  mutate(z = scale(price) + 3 + 1000 * as.numeric(cut)) %>%
  ggplot(aes(z)) +
  geom_point(aes(x = z - 2, y = 1), alpha = 0) +
  geom_density() +
  scale_x_continuous(breaks =  as.vector(sapply(1:5 * 1000, "+", 0:6)), 
                     labels = breaks) +
  facet_wrap(vars(cut), scales = "free_x") +
  theme(text = element_text(size = 16),
        axis.text.x = element_text(size = 6)) +
  geom_line(aes(x, p), data = shifted_densities, col = "red")

введите описание изображения здесь