составление двух уровней фактора в ggplot и split (ответвления) линий при их делении

Question

Рассмотрим следующее data.frame:

df <- structure(list(trial = structure(c(1L, 1L, 1L, 1L, 1L, 3L, 3L, 
3L, 3L, 3L, 4L, 4L, 4L, 4L, 4L, 2L, 2L, 2L, 2L, 2L, 5L, 5L, 5L, 
5L, 5L, 6L, 6L, 6L, 6L, 6L), .Label = c("ES1-7", "ES8-13", "ES14-25", 
"ES26-38", "SA1-13", "SA14-25"), class = "factor"), marker = c(0L, 
0L, 0L, 2L, 2L, 0L, 0L, 0L, 2L, 2L, 0L, 0L, 0L, 2L, 2L, 0L, 0L, 
0L, 2L, 2L, 0L, 0L, 0L, 2L, 2L, 0L, 0L, 0L, 2L, 2L), rs. = c("S1A_499864157", 
"S1B_566171302", "S1B_642616640", "S1A_494392059", "S1A_497201550", 
"S1A_499864157", "S1B_566171302", "S1B_642616640", "S1A_494392059", 
"S1A_497201550", "S1A_499864157", "S1B_566171302", "S1B_642616640", 
"S1A_494392059", "S1A_497201550", "S1A_499864157", "S1B_566171302", 
"S1B_642616640", "S1A_494392059", "S1A_497201550", "S1A_499864157", 
"S1B_566171302", "S1B_642616640", "S1A_494392059", "S1A_497201550", 
"S1A_499864157", "S1B_566171302", "S1B_642616640", "S1A_494392059", 
"S1A_497201550"), n = c(41L, 44L, 5L, 96L, 63L, 115L, 95L, 12L, 
282L, 160L, 320L, 200L, 25L, 402L, 320L, 42L, 32L, 2L, 82L, 64L, 
191L, 151L, 56L, 291L, 222L, 251L, 186L, 48L, 310L, 281L), prop = c(0.304054054054054, 
0.320945945945946, 0.287162162162162, 0.665540540540541, 0.452702702702703, 
0.311576354679803, 0.257389162561576, 0.261083743842365, 0.706896551724138, 
0.415024630541872, 0.594736842105263, 0.394736842105263, 0.32719298245614, 
0.72719298245614, 0.597368421052632, 0.438095238095238, 0.328571428571429, 
0.276190476190476, NA, 0.638095238095238, 0.427350427350427, 
0.351495726495727, 0.245726495726496, 0.636752136752137, 0.512820512820513, 
0.54517453798768, 0.415811088295688, 0.322381930184805, 0.650924024640657, 
0.600616016427105), BASE = c("T", "A", "G", "C", "C", "T", "A", 
"G", "C", "C", "T", "A", "G", "C", "C", "T", "A", "G", "C", "C", 
"T", "A", "G", "C", "C", "T", "A", "G", "C", "C"), alleles = c("C/T", 
"G/A", "A/G", "C/G", "C/T", "C/T", "G/A", "A/G", "C/G", "C/T", 
"C/T", "G/A", "A/G", "C/G", "C/T", "C/T", "G/A", "A/G", "C/G", 
"C/T", "C/T", "G/A", "A/G", "C/G", "C/T", "C/T", "G/A", "A/G", 
"C/G", "C/T")), row.names = c(NA, -30L), class = c("tbl_df", 
"tbl", "data.frame"))

Я строю график, используя следующий код:

tt <- ggplot(df, aes(x = trial, y = prop, color = rs.)) + 
  geom_point() +
  theme(axis.text.x = element_text(angle = 90,hjust = 1))+
  facet_grid(.~rs.)+
  geom_line(data = . %>%
              mutate(trial = as.numeric(trial)) %>%
              group_by(rs.) %>%
              summarise(x1 = list(spline(trial, prop, n = 50, method = "natural")[["x"]]),
                        y1 = list(spline(trial, prop, n = 50, method = "natural")[["y"]])) %>%

              tidyr::unnest(),
            aes(x = x1, y = y1)) +
  labs(subtitle="Favorable allele over time", 
       y="allele frequency", 
       x="Groups", 
       title="Yield QTL markers",
       col='markers')

И я получаю следующее изображение:

Я хотел бы объединить следующие уровни:

• "ES14-25" с "SA1-13";
• "ES26-38" с "SA14-25".

В моем желаемом графике я бы имел две ветки от ES8-13.Одна ветвь будет ES14-25 -> ES26-38, а другая SA1-13 -> SA14-25.Идея заключается в том, что «ES14-25» происходит одновременно с «SA1-13», а «ES26-38» происходит одновременно с «SA14-25».

со следующими двумяцифры, которые я пытаюсь визуально объяснить, что я имею в виду:

Answer 1

Вы можете обработать фрейм данных перед его передачей ggplot():

df %>%

  # remove rows without a valid value for the y-axis
  filter(!is.na(prop)) %>%

  # create appropriate x-axis values based on trial values
  mutate(x = case_when(trial == "ES1-7" ~ 1,
                       trial == "ES8-13" ~ 2,
                       trial %in% c("ES14-25", "SA1-13") ~ 3,
                       trial %in% c("ES26-38", "SA14-25") ~ 4,
                       TRUE ~ 0)) %>%

  # expand data frame by repeating the last point before divergence
  # for each rs. facet
  group_by(rs.) %>%
  mutate(last.point.before.divergence = x == max(x[x <= 2])) %>%
  ungroup() %>% 
  slice(c(1:n(),
          which(last.point.before.divergence))) %>% 

  # create group for line
  group_by(rs., x) %>%
  arrange(trial) %>% 
  mutate(group = seq(1, n())) %>%
  ungroup() %>% 

  ggplot(aes(x = x, y = prop, color = rs., 
             linetype = factor(group))) +
  geom_point() +
  geom_line(data = . %>%
              group_by(rs., group) %>%
              summarise(x1 = list(spline(x, prop, n = 50, method = "natural")[["x"]]),
                        y1 = list(spline(x, prop, n = 50, method = "natural")[["y"]])) %>%

              tidyr::unnest(),
            aes(x = x1, y = y1)) +
  facet_grid(.~rs.) +
  scale_x_continuous(breaks = seq(1, 4),
                     labels = c("ES1-7", "ES8-13",
                                "ES14-25 / SA1-13",
                                "ES26-38 / SA14-25")) +
  labs(subtitle="Favorable allele over time", 
       y="allele frequency", 
       x="Groups", 
       title="Yield QTL markers",
       col='markers') +
  theme(axis.text.x = element_text(angle = 90, hjust = 1, vjust = 0.5))