Как автоматически найти начало и конец последовательностей в R для прямоугольников в ggplot

Question

Я пытаюсь построить некоторые данные с помощью теневых прямоугольников.

Фрейм данных df выглядит так:

df <- data.frame(time  = seq(0.1, 2, 0.1), 
                 speed = c(seq(0.5, 5, 0.5), seq(5, 0.5, -0.5)),
                 type  = c("a", "a", "b", "b", "b", "b", "c", "c", "c", "b", "b", "b", "b", "b", "c", "a", "b", "c", "b", "b"))

Для прямоугольников на графике я определяю объект называется dfRect с переменными xmin и xmax.

dfRect <- data.frame(xmin = c(0.3, 1.0, 1.9), xmax = c(0.7, 1.5, 2.0))

Проблема в том, что мне нужно вручную найти xmin и xmax для начала и конца прямоугольников. Прямоугольник начинается (xmin) в начале временной последовательности b в столбце type и заканчивается в конце той же временной последовательности b. Одиночный b s можно игнорировать.

Вот сюжет, чтобы вы могли понять, что я пытаюсь выполнить sh:

ggplot() +
  geom_rect(data = dfRect, 
            aes(xmin = xmin, xmax = xmax, ymin = -Inf, ymax = Inf), 
            fill = "yellow", alpha = 0.4) +
  geom_line(data = df, aes(x = time, y = speed, color = type, group = 1), size = 3)

Итак, в конце концов, вопрос . Как я могу автоматизировать процесс определения xmin и xmax и автоматически создавать dfRect, чтобы мне не приходилось определять его самому?

Answer 1

Вот подход с использованием кодирования длин серий.

library(ggplot2)

df <- data.frame(time  = seq(0.1, 2, 0.1), 
                 speed = c(seq(0.5, 5, 0.5), seq(5, 0.5, -0.5)),
                 type  = c("a", "a", "b", "b", "b", "b", "c", "c", "c", "b", "b", "b", "b", "b", "c", "a", "b", "c", "b", "b"))

# Convert to runlength encoding
rle <- rle(df$type == "b")

# Ignoring the single "b"s
rle$values[rle$lengths == 1 & rle$values] <- FALSE

# Determine starts and ends
starts <- {ends <- cumsum(rle$lengths)} - rle$lengths + 1

# Build a data.frame from the rle
dfrect <- data.frame(
  xmin = df$time[starts],
  # We have to +1 the ends, because the linepieces end at the next datapoint
  # Though we should not index out-of-bounds, so we need to cap at the last end
  xmax = df$time[pmin(ends + 1, max(ends))],
  fill = rle$values
)

Этот график дает представление о том, что мы делали в приведенном выше коде:

ggplot() +
  geom_rect(data = dfrect, 
            aes(xmin = xmin, xmax = xmax, ymin = -Inf, ymax = Inf, fill = fill), 
            alpha = 0.4) +
  geom_line(data = df, aes(x = time, y = speed, color = type, group = 1), size = 3)

To get what you want you'd need to filter out the FALSEs.

ggplot() +
  geom_rect(data = dfrect[dfrect$fill,], 
            aes(xmin = xmin, xmax = xmax, ymin = -Inf, ymax = Inf), 
            alpha = 0.4, fill = "yellow") +
  geom_line(data = df, aes(x = time, y = speed, color = type, group = 1), size = 3)

If you are looking for a stat that can calculate this for you, have a look здесь . Отказ от ответственности: я написал эту функцию, которая делает то же самое, что и код, который я опубликовал выше.

Answer 2

Другой подход с rle, но с использованием data.table :: rleid.

Идея поворота принадлежит Стефану!

Я уверен, что канал можно как-то дополнительно укоротить

library(tidyverse)
df <- data.frame(
  time = seq(0.1, 2, 0.1),
  speed = c(seq(0.5, 5, 0.5), seq(5, 0.5, -0.5)),
  type = c("a", "a", "b", "b", "b", "b", "c", "c", "c", "b", "b", "b", "b", "b", "c", "a", "b", "c", "b", "b")
)
dfRect <-
  df %>%
  arrange(time, type) %>%
  mutate(id = data.table::rleid(type)) %>%
  group_by(type, id) %>%
  slice(c(1, n())) %>%
  distinct(time, id) %>%
  filter(type == "b" & n() > 1) %>%
  mutate(row = row_number()) %>%
  pivot_wider(names_from = row, names_prefix = "x", values_from = time)

ggplot() +
  geom_rect(
    data = dfRect,
    aes(xmin = x1, xmax = x2, ymin = -Inf, ymax = Inf),
    fill = "yellow", alpha = 0.4
  ) +
  geom_line(data = df, aes(x = time, y = speed, color = type, group = 1), size = 3)

Answer 3

Попробуйте это. Я добавил несколько пояснительных комментариев внутри кода:

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

df <- data.frame(time  = seq(0.1, 2, 0.1), 
                 speed = c(seq(0.5, 5, 0.5), seq(5, 0.5, -0.5)),
                 type  = c("a", "a", "b", "b", "b", "b", "c", "c", "c", "b", "b", "b", "b", "b", "c", "a", "b", "c", "b", "b"))

dfRect <- df %>% 
  arrange(time, type) %>% 
  # Get start and end of sequences
  mutate(is_b_start = type == "b" & lag(type) != "b",
         is_b_end = type != "b" & lag(type) == "b") %>% 
  filter(is_b_start | is_b_end) %>%
  # Get id of sequences
  mutate(id = cumsum(is_b_start),
         type = ifelse(is_b_start, "min", "max")) %>% 
  select(time, id, type) %>%
  # To wide format gives xmin and xmax for each sequence 
  tidyr::pivot_wider(names_from = type, names_prefix = "x", values_from = time) %>% 
  # In case: Fill last with max time
  tidyr::replace_na(list(xmax = max(df$time)))
  
ggplot() +
  geom_rect(data = dfRect, 
            aes(xmin = xmin, xmax = xmax, ymin = -Inf, ymax = Inf), 
            fill = "yellow", alpha = 0.4) +
  geom_line(data = df, aes(x = time, y = speed, color = type, group = 1), size = 3)

^{Created on 2020-06-21 by the пакет репекс (v0.3.0)}