ggplot2 - настраиваемая гистограмма с ковриком

Question

Я пытаюсь создать собственную гистограмму с ковриком, показывающим исходные значения по оси X.

Я собираюсь использовать набор данных mtcars для иллюстрации. Это не лучший набор данных для этого вопроса ... но, надеюсь, читатель поймет, чего я пытаюсь достичь ...

Ниже показана основная гистограмма c без каких-либо попыток построения коврового графика.

Я хочу создать гистограмму с помощью geom_bar, поскольку это обеспечивает большую гибкость с настраиваемыми ячейками.

Мне также нужен небольшой промежуток между столбцами гистограммы (т.е. ширина = 0,95) .... что усложняет задачу.

library(dplyr)
library(ggplot2)

# create custom bins
vct_seq <- c(seq(from = 10, to = 25, by = 5), 34)
mtcars$bin <- cut(mtcars$mpg, breaks = vct_seq)

# create data.frame for the ggplot graph..using bins above
df_mtcars_count <- mtcars %>% group_by(bin) %>% summarise(count = n())

# indicative labels
vct_labels <- c("bin 1", "bin 2", "bin 3", "bin 4")

# attempt 1 - basic plot -- no rug plot
p <- ggplot(data = df_mtcars_count, aes(x = bin, y = count))
p <- p + geom_bar(stat = "identity", width = 0.95)
p <- p + geom_text(aes(label = count), vjust = -0.5)
p <- p + scale_x_discrete("x title to go here", labels = df_mtcars_count$bin, breaks = df_mtcars_count$bin)
p

Затем попробуйте добавить базовый c график коврика по оси X. Очевидно, что это не работает, поскольку geom_bar и geom_rug имеют совершенно разные масштабы.

# attempt 2 with no scaling.... doesn't work as x scale for ordinal (bins) and 
# x scale for continuous (mpg) do not match
p <- ggplot(data = df_mtcars_count, aes(x = bin, y = count))
p <- p + geom_bar(stat = "identity", width = 0.95)
p <- p + geom_text(aes(label = count), vjust = -0.5)
p <- p + scale_x_discrete("x title to go here", labels = df_mtcars_count$bin, breaks = df_mtcars_count$bin)
p <- p + geom_rug(data = mtcars, aes(x = mpg), inherit.aes = F, alpha = 0.3)
p

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

Сначала определить функцию линейного сопоставления ...

fn_linear_map <- function(vct_existing_val, vct_new_range) {
  # example....converts 1:20 into the range 1 to 10 like this:
  # fn_linear_map(1:20, c(1, 10))
  fn_r_diff <- function(x) x %>% range() %>% diff()
  flt_ratio <- fn_r_diff(vct_new_range) / fn_r_diff(vct_existing_val)
  vct_old_min_offset <- vct_existing_val  - min(vct_existing_val)
  vct_new_range_val <- (vct_old_min_offset * flt_ratio) + min(vct_new_range)
  return(vct_new_range_val)
}

Теперь примените функцию ... мы пытаемся сопоставить миль на галлон в диапазоне от 1 до 4 (что является попыткой сопоставить порядковый номер)

mtcars$mpg_remap <- fn_linear_map(mtcars$mpg, c(1, 4))

Попробуйте построить график еще раз .... ближе ... но не совсем точно ...

# attempt 3:  getting closer but doesn't really match the ordinal scale
p <- ggplot(data = df_mtcars_count, aes(x = bin, y = count))
p <- p + geom_bar(stat = "identity", width = 0.95)
p <- p + geom_text(aes(label = count), vjust = -0.5)
p <- p + scale_x_discrete("x title to go here", labels = df_mtcars_count$bin, breaks = df_mtcars_count$bin)
p <- p + geom_rug(data = mtcars, aes(x = mpg_remap), inherit.aes = F, alpha = 0.3)
p

График выше приближается к тому, что я хочу .... но коврик график не совпадает с фактическими данными ... например, максимальное наблюдение (33.9) должно отображаться почти выровненным с правой стороной полосы ... см. ниже:

mtcars %>% filter(bin == "(25,34]") %>% arrange(mpg) %>% dplyr::select(mpg, mpg_remap)

Answer 1

Ваш масштаб не имеет смысла для меня, поскольку вы показываете корзину, которая в два раза шире, используя ту же ширину полосы. Использование коврика в сочетании с ковром кажется мне в лучшем случае запутанным, а в худшем - вводящим в заблуждение. Я предлагаю вам построить полосы с правильной шириной, после чего коврик станет тривиальным.

Я думаю, что лучшим решением будет просто использовать geom_histogram:

ggplot(mtcars, aes(mpg)) + 
  geom_histogram(breaks = vct_seq, col = 'grey80') +
  geom_rug(aes(mpg, y = NULL))

Если вам действительно нужны промежутки между стержнями, вам придется проделать больше работы:

library(tidyr)
d <- mtcars %>% 
  count(bin) %>% 
  separate(bin, c('min', 'max'), sep = ',', remove = FALSE) %>% 
  mutate_at(vars('min', 'max'), readr::parse_number) %>% 
  mutate(
    middle = min + (max - min) / 2,
    width = 0.9 * (max - min)
  )

ggplot(d, aes(middle, n)) + 
  geom_col(width = d$width) +
  geom_rug(aes(mpg, y = NULL), mtcars)