Обнаруживать последовательности упорядоченных строк и группировать их с помощью R

Question

У меня есть вектор строки с примерно 500 КБ элементов в нем, и я хочу присвоить значение каждому элементу, чтобы показать номер группы каждого элемента.

Критерии группировки выглядят следующим образом:

• номер группы назначается последовательно, начиная с верхней части списка
• Каждому элементу следует назначать разные группы, если не менее 3 последовательных элементов находятся в возрастающем алфавитном порядке, в котором эти последовательные элементы будут в одной группе.

Как мне это сделать в R?

Например и ожидаемый результат:

> my_strings <- c("xx1", "1xxx", "abc.xyz", "a", "ad022", "ghj1", "kf1", "991r",
+                 "jdd", "12vd", "r34o", "z", "034mh")
> expected_output <- c(1, 2, 3, 4, 4, 4, 4, 5, 6, 7, 7, 7, 8)
> (df <- data.frame(input = my_strings, output = expected_output))
     input output
1      xx1      1
2     1xxx      2
3  abc.xyz      3
4        a      4
5    ad022      4
6     ghj1      4
7      kf1      4
8     991r      5
9      jdd      6
10    12vd      7
11    r34o      7
12       z      7
13   034mh      8

Пока что я пытаюсь использовать dplyr::lead и назначать порядок на основе двух последовательных элементов. Я не знаю, что дальше делать.

res <- as_tibble(my_strings) %>%
  mutate(after = lead(my_strings))
res$pre_group = apply(res, 1, function(x) order(c(x[1], x[2]))[2])

Answer 1

(Черт, это было непросто: -)

tidyverse

library(dplyr)
df %>%
  mutate(r1 = cumsum(c(TRUE, diff(rank(input)) < 0)) + 0) %>%
  group_by(r1) %>%
  mutate(r2 = r1 + seq(0, 0.9*(n() < 3), len = n()) / n()) %>%
  ungroup() %>%
  mutate(r1 = with(list(rl = rle(r2)$lengths), rep(seq_along(rl), times = rl))) %>%
  select(-r2)
# # A tibble: 13 x 3
#    input   output    r1
#    <chr>    <dbl> <int>
#  1 xx1          1     1
#  2 1xxx         2     2
#  3 abc.xyz      3     3
#  4 a            4     4
#  5 ad022        4     4
#  6 ghj1         4     4
#  7 kf1          4     4
#  8 991r         5     5
#  9 jdd          6     6
# 10 12vd         7     7
# 11 r34o         7     7
# 12 z            7     7
# 13 034mh        8     8

(Длинный with(...) в mutate - это просто встроенная версия data.table::rleid .)

data.table

library(data.table)
as.data.table(df)[
, r1 := cumsum(c(TRUE, diff(rank(input)) < 0)) + 0 ][
, r1 := r1 + seq(0, 0.9*(.N < 3), len = .N), by = .(r1) ][
, r1 := rleid(r1) ]

Если вы хотите немного размыть линии R-диалектов, то

library(data.table)
library(magrittr)
as.data.table(df) %>%
  .[, r1 := cumsum(c(TRUE, diff(rank(input)) < 0)) + 0 ] %>%
  .[, r1 := r1 + seq(0, 0.9*(.N < 3), len = .N), by = .(r1) ] %>%
  .[, r1 := rleid(r1) ]

Примечания:

• ... + 0 сокращенно от as.numeric(...). Это потому, что data.table применяет исходный class столбца при обновлении столбца; поскольку первое определение r1 (без +0) будет integer, следующее переназначение r1 вернет numeric. Однако, поскольку data.table сохраняет исходный класс, числа будут преобразованы (trunc ated) в целое число, и мои усилия будут остановлены.

• seq(0, 0.9*(...)) сокращается до seq(0,0), когда в группе трое или более, что приводит к закрытию этой группы. (Здесь используются dplyr n() и data.table .N для размера группы.)

• реализации немного отличаются, потому что dplyr запрещает изменение группировки переменная (и); data.table не имеет с этим проблем. (Я не уверен, какое направление правильное или лучше ...)

Answer 2

Не так хорошо, как у r2evans, но тоже вроде дает результат.

x <- my_strings
n <- length(x)
c(FALSE,x[-1L] > x[-n]) &
c(FALSE,FALSE,x[-1L][-1L] > x[-n][-(n-1)]) &
c(FALSE,FALSE,FALSE,x[-1L][-1L][-1L] > x[-n][-(n-1)][-(n-2)])

(lead(x, 1) > x & lead(x,2) > lead(x,1)) |
  (lag(x, 1) < x & lead(x,1) > x) |
  (lag(x, 1) < x & lag(x,2) < lag(x,1)) -> condition

condition[is.na(condition)] <- FALSE # remove NAs

#to visualize
tibble(lag(x,2), lag(x,1), x, lead(x,1), lead(x,2), condition)

# There may be a better way than a loop
cur_class <- 0
classes <- integer(n)
for(i in 1:(n)){
  if(!condition[i]){ #not in a sequence
    cur_class <- cur_class + 1
    classes[i] <- cur_class
  } else if(!condition[i-1]){ #first of a sequence
    cur_class <- cur_class + 1
    classes[i] <- cur_class
  } else{ #mid-sequence
    classes[i] <- cur_class
  }
}

tibble(x, classes, condition*1L)

# A tibble: 13 x 3
#   x       classes `condition * 1L`
#  <chr>     <dbl>            <int>
# 1 xx1           1                0
# 2 1xxx          2                0
# 3 abc.xyz       3                0
# 4 a             4                1
# 5 ad022         4                1
# 6 ghj1          4                1
# 7 kf1           4                1
# 8 991r          5                0
# 9 jdd           6                0
# 10 12vd          7                1
# 11 r34o          7                1
# 12 z             7                1
# 13 034mh         8                0