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.
Кто-нибудь видит сценарий, где это сломается?
