Цвет линии и ширина по уклону в ggplot2

Question

Это очень тесно связано с этим вопросом , а также этим , ответы на которые я не понимаю, по крайней мере, в этом контексте. Я хотел бы сделать разницу между увеличением и уменьшением оценок (например, повторные психологические измерения от T1 до T2) заметными, поместив градиент в стиле тепловой карты на линии, основанные на их наклонах. Другими словами, я хотел бы использовать, например, Viridis - адская шкала, так что линии, которые уменьшаются наиболее резко, стремятся к темноте, а линии, которые увеличиваются наиболее резко, - к свету.

Большое спасибо за любые идеи!

data <- data.frame(id = 1:500, 
                               Intrinsic_01_T1 = sample(1:5, 500, replace = TRUE), 
                               Intrinsic_02_T1 = sample(1:5, 500, replace = TRUE), 
                               Intrinsic_03_T1 = sample(1:5, 500, replace = TRUE), 
                               Intrinsic_01_T2 = sample(1:5, 500, replace = TRUE, prob = c(0.1, 0.1, 0.2, 0.3, 0.3)), 
                               Intrinsic_02_T2 = sample(1:5, 500, replace = TRUE), 
                               Intrinsic_03_T2 = sample(1:5, 500, replace = TRUE, prob = c(0.3, 0.3, 0.2, 0.1, 0.1)))

pd <- position_dodge(0.4)

data %>% 
  tidyr::gather(variable, value, -id) %>% 
  tidyr::separate(variable, c("item", "time"), sep = "_T") %>% 
  dplyr::mutate(value = jitter(value, amount = 0.1)) %>% # Y-axis jitter to make points more readable
ggplot(aes(x = time, y = value, group = id)) +
  geom_point(size = 1, alpha = .2, position = pd) +
  geom_line(alpha = .2, position = pd) +
  ggtitle('Multiple indicator LCS model') + 
  ylab('Intrinsic motivation scores') +
  xlab('Time points') + 
  facet_wrap("item")

Answer 1

Хитрость заключается в том, чтобы рассчитать наклон для каждой линии перед построением графика. Для этого вы можете group by время и элемент, а затем рассчитать наклон для каждой линии.

data %>% 
  tidyr::gather(variable, value, -id) %>% 
  tidyr::separate(variable, c("item", "time"), sep = "_T") %>% 
  dplyr::mutate(value = jitter(value, amount = 0.1)) %>%  # Y-axis jitter to make points more readable
  group_by(id,item) %>% 
  mutate(slope = (value[time==2] - value[time==1])/(2-1)) %>% 
  ggplot(aes(x = time, y = value, group = id)) +
  geom_point(size = 1, alpha = .2, position = pd) +
  geom_line(alpha = .2, position = pd, aes(color = slope)) +
  scale_color_viridis_c(option = "inferno")+
   ggtitle('Multiple indicator LCS model') + 
  ylab('Intrinsic motivation scores') +
  xlab('Time points') + 
  facet_wrap("item")

В результате: