ID-фрагменты строк по начальному и конечному значению

Мне нужно идентифицировать фрагменты строк в таблице данных с помощью начальной строки и критерия конечной строки. В MWE ниже стартовая строка определяется colA == "d", и группа продолжается до тех пор, пока colA == "a"

library(data.table)
in.data <- data.table(colA=c("b", "f", "b", "k", "d", "b", "a", "s", "a", "n", "d", "f", "d", "a", "t"))
in.data$wanted.column <- c(NA, NA, NA, NA, 1, 1, 1, NA, NA, NA, 2, 2, 2, 2, NA)

in.data
#     colA wanted.column
#  1:    b            NA
#  2:    f            NA
#  3:    b            NA
#  4:    k            NA
#  5:    d             1
#  6:    b             1
#  7:    a             1
#  8:    s            NA
#  9:    a            NA
# 10:    n            NA
# 11:    d             2
# 12:    f             2
# 13:    d             2
# 14:    a             2
# 15:    t            NA

(Не имеет значения, являются ли внегрупповые значения NA, нолем или любым другим идентифицируемым результатом)

Ответ 1

UPDATE

В исходной версии ответа были найдены кратчайшие последовательности, что было неправильно, поскольку они могли содержать стартовый символ в середине, например. c('d','f','d','a'). Измененная версия ответа устраняет эту проблему.

UPDATE2

Мне сообщили, что, когда две последовательности следуют друг за другом (например, in.data <- data.table(colA=c("b", "f", "b", "k", "d", "b", "a", "d", "f", "d", "a", "t"))), они перечисляются как одно решение, что неверно. Здесь я исправляю эту проблему, отслеживая появление символов symbol.stop в colA.

Настройка

library(data.table)
in.data <- data.table(colA=c("b", "f", "b", "k", "d", "b", "a", "s", "a", "n", "d", "f", "d", "a", "t"))
symbol.start='d'
symbol.stop='a'

Фактический код

in.data[,y := rev(cumsum(rev(colA)==symbol.stop))][,out:=(!match(symbol.start,colA,nomatch=.N+1)>1:.N),by=y]

in.data$out[in.data$out] <- as.factor(max(in.data$y)-in.data$y[in.data$out])

Здесь [,y := rev(cumsum(rev(colA)==symbol.stop))] создает столбец y, который можно использовать для группировки данных, заданных вхождениях symbol.stop с обратной стороны. Выражение [,out:=(!match(symbol.start,colA,nomatch=.N+1)>1:.N),by=y] возвращает логический вектор, указывающий, принадлежит ли строка последовательности start.symbol...end.symbol. Следующая строка необходима для перечисления таких последовательностей.

Очистка и вывод

in.data$y <- NULL   

in.data
#     colA out
#  1:    b   0
#  2:    f   0
#  3:    b   0
#  4:    k   0
#  5:    d   1
#  6:    b   1
#  7:    a   1
#  8:    s   0
#  9:    a   0
# 10:    n   0
# 11:    d   2
# 12:    f   2
# 13:    d   2
# 14:    a   2
# 15:    t   0

Update3

На всякий случай кому-то это нужно, однострочное решение:

in.data[     , y := rev(cumsum(rev(colA)==symbol.stop))
      ][     , z:=(!match(symbol.start,colA,nomatch=.N+1)>1:.N), by=y
      ][ z==T, out:=as.numeric(factor(y,levels=unique(y)))
      ][     , c('z','y'):=list(NULL,NULL)]

Ответ 2

Я уверен, что кто-то придумает приятное решение data.table. В ожидании, здесь другая возможность base:

in.df <- as.data.frame(in.data)

# index of "d", start index
start <- which(in.df$colA == "d")

# index of "a"
idx_a <- which(in.df$colA == "a")

# end index: for each start index, select the first index of "a" which is larger
end <- a[sapply(start, function(x) which.max(x < idx_a))]

# check if runs overlap and create groups of runs
lag_end <- c(0, head(end, -1))
run <- cumsum(start >= lag_end)

df <- data.frame(start, end, run)

# within each run, expand the sequence of idx, from min(start) to max(end)
df2 <- do.call(rbind,
        by(df, df$run, function(x){
          data.frame(run = x$run, idx = min(x$start):max(x$end))
        })
)

# add an empty 'run' variable to in.df
in.df$run <- NA

# assign df2$run at idx in in.data
in.df$run[df2$idx] <- df2$run

#    idx colA wanted.column run
# 1    1    b            NA  NA
# 2    2    f            NA  NA
# 3    3    b            NA  NA
# 4    4    k            NA  NA
# 5    5    d             1   1
# 6    6    b             1   1
# 7    7    a             1   1
# 8    8    s            NA  NA
# 9    9    a            NA  NA
# 10  10    n            NA  NA
# 11  11    d             2   2
# 12  12    f             2   2
# 13  13    d             2   2
# 14  14    a             2   2
# 15  15    t            NA  NA

Ответ 3

Опять же, в base-R, бит противный, но имеет меньшее количество итераций и нет, если elses.

library(data.table)
in.data <- data.table(colA=c("b", "f", "b", "k", "d", "b", "a", "s", "a", "n", "d", "f", "d", "a", "t"))
in.data$out <- rep(NA,nrow(in.data))

d <- which(in.data$colA=="d")
a <- which(in.data$colA=="a")
end <- rep(NA, length(d))
for (i in seq_along(d)){
  begin <-  d[i]
if(begin>=max(a)) # this cdn accomodates a case where no "a" appears after some "d"
      break
  end[i] <- min(a[d[i]<a])
  in.data$out[begin: end[i]] <-  sum(!is.na(unique(end)))
}
in.data
#    colA out
# 1:    b  NA
# 2:    f  NA
# 3:    b  NA
# 4:    k  NA
# 5:    d   1
# 6:    b   1
# 7:    a   1
# 8:    s  NA
# 9:    a  NA
#10:    n  NA
#11:    d   2
#12:    f   2
#13:    d   2
#14:    a   2
#15:    t  NA

Ответ 4

Это оказалось сложным, но у него нет петель или совпадений (и поэтому должно быть быстро):

library(zoo)

in.data[, newcol := (colA=='d') - (colA=='a')
      ][newcol == 0 & 1:.N > 1, newcol := NA
      ][, newcol := na.locf(newcol, F)
      ][newcol < 0, newcol := 0
      ][, newcol := newcol * cumsum(diff(c(0, newcol)) != 0)
      ][newcol == 0 & c(NA, head(newcol, -1)), newcol := NA
      ][, newcol := na.locf(newcol, F)
      ][newcol != 0, newcol := .GRP, by = newcol][]
#    colA wanted.column newcol
# 1:    b            NA      0
# 2:    f            NA      0
# 3:    b            NA      0
# 4:    k            NA      0
# 5:    d             1      1
# 6:    b             1      1
# 7:    a             1      1
# 8:    s            NA      0
# 9:    a            NA      0
#10:    n            NA      0
#11:    d             2      2
#12:    f             2      2
#13:    d             2      2
#14:    a             2      2
#15:    t            NA      0

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

Ответ 5

Немного противно быть честным, но это сработало для меня:

library(data.table)
in.data <- data.table(colA=c("b", "f", "b", "k", "d", "b", "a", "s", "a", "n", "d", "f", "d", "a", "t"))

in.data$out <- rep(NA,nrow(in.data))

activator <- FALSE
counter <- 1
for (i in 1:nrow(in.data)) {
      if (activator == TRUE & in.data$colA[i] !='a') {
        in.data$out[i] <- counter
        next
      }
      if( in.data$colA[i]=='d') {
        activator <- TRUE
        in.data$out[i] <- counter
      } else if (in.data$colA[i]=='a' & activator==TRUE ) {
        in.data$out[i] <- counter
        counter <- counter + 1
        activator <- FALSE
      } else {next}
}
in.data

Вывод:

> in.data
    colA out
 1:    b  NA
 2:    f  NA
 3:    b  NA
 4:    k  NA
 5:    d   1
 6:    b   1
 7:    a   1
 8:    s  NA
 9:    a  NA
10:    n  NA
11:    d   2
12:    f   2
13:    d   2
14:    a   2
15:    t  NA

Вы можете сделать sapply, если хотите, но инструкции if настолько велики, что for-loop может быть понятнее читать...

Ответ 6

Не проверяется строго, но вот еще один из них:

require(data.table)
cj_dt = CJ(which(in.data$colA == "d"), which(in.data$colA == "a"))[V1 <= V2]
idx1 = cj_dt[, if (.N > 1) list(V2 = V2[1L]), by=V1]
idx2 = cj_dt[!idx1][, list(V1 = V1[1L]), by=V2]
ans = rbind(idx1, idx2)

#    V1 V2
# 1:  5  7
# 2: 11 14

Теперь все, что нам нужно сделать, это заменить 5:7, 11:14 на wanted.column на 1.

Кто-нибудь видит сценарий, где это сломается?