Сопоставьте подстроку двух векторов и создайте новый вектор, объединяющий их
Рассмотрим два вектора.
a <- c(123, 234, 432, 223)
b <- c(234, 238, 342, 325, 326)
Теперь я хочу сопоставить последние две цифры a с двумя двумя цифрами b и создать новый вектор, вставляющий первую цифру a, совпадающую часть и последнюю цифру b. Мой ожидаемый результат:
[1] 1234 1238 2342 4325 4326 2234 2238
Для простоты рассмотрим все элементы всегда длиной 3.
Я пробовал:
sub_a <- substr(a, 2, 3) #get last two digits of a
sub_b <- substr(b, 1, 2) #get first two digits of b
common <- intersect(sub_a, sub_b)
common дает мне общие элементы в a и b, которые:
[1] "23" "34" "32"
а затем я использую match и paste0 вместе, и я получаю неполный вывод.
paste0(a[match(common, sub_a)], substr(b[match(common, sub_b)], 3, 3))
#[1] "1234" "2342" "4325"
как match соответствует только первым вхождениям.
Как я могу достичь ожидаемого результата?
Ответы
Ответ 1
Возможное решение:
a <- setNames(a, substr(a,2,3))
b <- setNames(b, substr(b,1,2))
df <- merge(stack(a), stack(b), by = 'ind')
paste0(substr(df$values.x,1,1), df$values.y)
который дает:
[1] "1234" "1238" "2234" "2238" "4325" "4326" "2342"
Вторая альтернатива:
a <- setNames(a, substr(a,2,3))
b <- setNames(b, substr(b,1,2))
l <- lapply(names(a), function(x) b[x == names(b)])
paste0(substr(rep(a, lengths(l)),1,1), unlist(l))
который дает тот же результат и значительно быстрее (см. эталон).
Ответ 2
Вероятно, немного сложный, но работает:
unlist( sapply( a, function(x) {
regex <- paste0( substr(x, 2, 3), '(\\d)')
z <- sub(regex, paste0(x, "\\1"), b)
z[!b %in% z]
} ))
которые дают: [1] "1234" "1238" "2342" "4325" "4326" "2234" "2238"
Основная идея состоит в том, чтобы создать регулярное выражение для каждой записи в a, применить это регулярное выражение к b и заменить значения текущим значением и добавить только последнюю цифру (часть (\\d) регулярного выражения, затем фильтровать результирующий вектор, чтобы вернуть только измененные значения.
Из любопытства я сделал небольшой ориентир (добавление sub_a и sub_b в Sotos и Heikki отвечает так, чтобы все начинались с одних и тех же начальных векторов a 400 наблюдений и b 500 наблюдений):
Unit: milliseconds
expr min lq mean median uq max neval
Jaap(a, b) 341.0224 342.6853 345.2182 344.3482 347.3161 350.2840 3
Tensi(a, b) 415.9175 416.2672 421.9148 416.6168 424.9134 433.2100 3
Heikki(a, b) 126.9859 139.6727 149.3252 152.3594 160.4948 168.6302 3
Sotos(a, b) 151.1264 164.9869 172.0310 178.8474 182.4833 186.1191 3
MattWBase(a, b) 286.9651 290.8923 293.3795 294.8195 296.5867 298.3538 3
Ответ 3
Другим способом может быть использование expand.grid, поэтому, набрав sub_a и sub_b,
d1 <- expand.grid(a, b, stringsAsFactors = FALSE)
d2 <- expand.grid(sub_a, sub_b, stringsAsFactors = FALSE)
i1 <- d2$Var1 == d2$Var2
d1 <- d1[i1,]
d1$Var1 <- substr(d1$Var1, 1, 1)
do.call(paste0, d1)
#[1] "1234" "2234" "1238" "2238" "2342" "4325" "4326"
Ответ 4
Здесь другая опция в базе R:
foo <- function(a, b) {
split_a <- split(a, substr(a, 2, 3))
split_b <- split(substr(b, 3, 3), substr(b, 1, 2))
idx <- intersect(names(split_a), names(split_b))
stopifnot(length(idx) > 0)
unlist(Map(function(x,y) outer(x, y, paste0), split_a[idx], split_b[idx]),
use.names = FALSE)
}
foo(a, b)
# [1] "1234" "2234" "1238" "2238" "4325" "4326" "2342"
Update:
Я использовал определения функций из fooobar.com/questions/335831/..., чтобы сделать еще один тест со всеми ответами и большими данными. Входные данные и полученные результаты:
set.seed(123)
a <- sample(100:999, 1e4, TRUE)
b <- sample(100:999, 1e3, TRUE)
library(microbenchmark)
library(dplyr)
res <- microbenchmark(docendo(a, b),
Jaap1(a, b),
Jaap2(a, b),
Sotos(a, b),
Tensi(a, b),
Heikki(a, b),
Matt_base(a, b),
Matt_dplyr(a, b),
zx8754(a, b),
times = 10, unit = "relative")
Unit: relative
expr min lq mean median uq max neval
docendo(a, b) 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000 10
Jaap1(a, b) 14.002977 13.724432 13.347755 13.433175 12.788948 13.301811 10
Jaap2(a, b) 4.364993 4.936248 5.201879 5.125639 5.060425 7.520069 10
Sotos(a, b) 22.215750 23.850280 25.743047 25.177676 28.274083 28.288089 10
Tensi(a, b) 231.230360 234.830000 246.587532 242.345573 260.784725 273.184452 10
Heikki(a, b) 135.615708 136.900943 144.775845 146.314048 150.546406 156.873954 10
Matt_base(a, b) 13.274675 12.995334 13.402940 12.723798 12.432802 18.881093 10
Matt_dplyr(a, b) 1.299223 1.314568 1.420479 1.345850 1.380378 1.807671 10
zx8754(a, b) 9.607226 10.175381 10.486580 10.136439 10.096818 13.410858 10
Интересно, когда я воспроизвожу сравнение ответа Франка и моего из теста, я получаю противоположные результаты:
Frank <- function(a, b) {
aDT <- as.data.table(tstrsplit(a, ""))
bDT <- setnames(as.data.table(tstrsplit(b, "")), c("V2", "V3", "V4"))
merge(aDT, bDT, allow.cartesian = TRUE)[, paste0(V1, V2, V3, V4)]
}
set.seed(1) # same input size as in the cw benchmark answer
a <- sample(100:999, 8e3, TRUE)
b <- sample(100:999, 1e4, TRUE)
microbenchmark(Frank(a, b), docendo(a, b), unit = "relative", times = 10)
Unit: relative
expr min lq mean median uq max neval
Frank(a, b) 1.37435 1.390417 1.500996 1.470548 1.644079 1.616446 10
docendo(a, b) 1.00000 1.000000 1.000000 1.000000 1.000000 1.000000 10
all.equal(sort(docendo(a, b)), sort(Frank(a, b)))
#[1] TRUE
Ответ 5
Тест (добавление sub_a и sub_b в Sotos и Heikki отвечает так, чтобы все начинались с тех же начальных векторов a из 800 наблюдений и b из 1000 наблюдений).
Запуск теста с помощью:
library(dplyr)
library(data.table)
library(microbenchmark)
a <- sample(100:999, 8e3, TRUE)
b <- sample(100:999, 1e4, TRUE)
microbenchmark(Jaap1(a,b), Jaap2(a,b), Tensi(a,b), Heikki(a,b), Sotos(a,b),
Matt_base(a,b), Matt_dplyr(a,b), Docendo(a,b),
zx8754(a,b), zx8754for(a,b), Frank(a,b),
times = 50, unit = 'relative')
дает:
Unit: relative
expr min lq mean median uq max neval cld
Jaap1(a, b) 19.668483 19.316194 17.2373827 18.921573 18.829932 7.8792713 50 d
Jaap2(a, b) 4.253151 4.365420 4.0557281 4.309247 4.398149 2.2149125 50 b
Tensi(a, b) 241.682216 238.197815 212.2844582 233.473689 233.367619 93.3562331 50 h
Heikki(a, b) 114.895836 113.754054 101.2781709 111.637570 110.541708 44.9437229 50 g
Sotos(a, b) 27.598767 28.725937 25.7469518 28.534011 28.638413 11.6995642 50 e
Matt_base(a, b) 19.159883 18.834180 16.8853660 18.513498 18.416194 7.8329323 50 d
Matt_dplyr(a, b) 1.108230 1.106051 1.0203776 1.102078 1.098476 1.0131898 50 a
Docendo(a, b) 1.000000 1.000000 1.0000000 1.000000 1.000000 1.0000000 50 a
zx8754(a, b) 11.601730 12.986763 11.7859245 13.054720 13.234842 5.6944437 50 c
zx8754for(a, b) 90.448168 92.906445 82.4905438 91.092609 90.160010 36.1277145 50 f
Frank(a, b) 1.070775 1.070202 0.9621499 1.063978 1.055540 0.4459918 50 a
Используемые функции:
Jaap1 <- function(a,b) {
a <- setNames(a, substr(a,2,3))
b <- setNames(b, substr(b,1,2))
df <- merge(stack(a), stack(b), by = 'ind')
paste0(substr(df$values.x,1,1), df$values.y)
}
Jaap2 <- function(a,b) {
a <- setNames(a, substr(a,2,3))
b <- setNames(b, substr(b,1,2))
l <- lapply(names(a), function(x) b[x == names(b)])
paste0(substr(rep(a, lengths(l)),1,1), unlist(l))
}
Tensi <- function(a,b) {
unlist(sapply(a,function(x) {regex <- paste0(substr(x,2,3),'(\\d)'); z <- sub(regex,paste0(x,"\\1"),b); z[!b %in% z] } ))
}
Heikki <- function(a,b) {
sub_a <- substr(a, 2, 3)
sub_b <- substr(b, 1, 2)
result <- c()
for (ai in a) {
sub_ai <- substr(ai,2,3)
if (sub_ai %in% sub_a) {
b_match <- (sub_b == sub_ai)
result <- c(result,paste0(ai,substr(b[b_match],3,4)))
}
}
result
}
Sotos <- function(a,b) {
sub_a <- substr(a, 2, 3)
sub_b <- substr(b, 1, 2)
d1 <- expand.grid(a, b, stringsAsFactors = FALSE)
d2 <- expand.grid(sub_a, sub_b, stringsAsFactors = FALSE)
i1 <- d2$Var1 == d2$Var2
d1 <- d1[i1,]
d1$Var1 <- substr(d1$Var1, 1, 1)
do.call(paste0, d1)
}
Matt_base <- function(a,b) {
a1 <- data.frame(a)
b1 <- data.frame(b)
a1$first_a = substr(a1$a, 1, 1)
a1$last_a = substr(a1$a, 2, 3)
b1$first_b = substr(b1$b, 1, 2)
b1$last_b = substr(b1$b, 3, 3)
c1 <- merge(a1, b1, by.x = "last_a", by.y = "first_b")
results <- paste0(c1$a, c1$last_b)
}
Matt_dplyr <- function(a,b) {
a1 <- data.frame(a)
b1 <- data.frame(b)
a1 <- a1 %>% mutate(first_a = substr(a, 1, 1), last_a = substr(a, 2, 3))
b1 <- b1 %>% mutate(first_b = substr(b, 1, 2), last_b = substr(b, 3, 3))
c1 <- inner_join(a1, b1, by = c("last_a" = "first_b"))
results <- paste0(c1$a, c1$last_b)
}
Docendo <- function(a, b) {
split_a <- split(a, substr(a, 2, 3))
split_b <- split(substr(b, 3, 3), substr(b, 1, 2))
idx <- intersect(names(split_a), names(split_b))
stopifnot(length(idx) > 0)
unlist(Map(function(x,y) outer(x, y, paste0), split_a[idx], split_b[idx]),
use.names = FALSE)
}
zx8754 <- function(a, b) {
unlist(sapply(a, function(i) i * 10 + (b %% 10)[i %% 100 == b %/% 10]))
}
zx8754for <- function(a, b) {
res <- integer()
for(i in a) res <- c(res, i * 10 + (b %% 10)[i %% 100 == b %/% 10])
res
}
Frank <- function(a, b) {
aDT <- as.data.table(tstrsplit(a, ""))
bDT <- setnames(as.data.table(tstrsplit(b, "")), c("V2", "V3", "V4"))
merge(aDT, bDT, allow.cartesian = TRUE)[, paste0(V1, V2, V3, V4)]
}
Ответ 6
Как насчет немного математики *:
unlist(sapply(a, function(i)
i * 10 + (b %% 10)[i %% 100 == b %/% 10]))
* Предположение: все цифры 3 цифры, но это, конечно, можно отрегулировать в пределах sapply.
Проверьте вывод, выход будет в другом порядке, чем другие ответы, а вывод будет числовым, а не символом.
identical(sort(as.numeric(docendo(a, b))), sort(zx8754(a, b)))
# [1] TRUE
identical(sort(as.numeric(jaap(a, b))), sort(zx8754(a, b)))
# [1] TRUE
Редактировать: версия forloop кажется 3 раза быстрее (с примерными небольшими данными, с большим набором, на самом деле это на 3 раза медленнее, см. postmark).
zx8754 <- function(a, b) {
unlist(sapply(a, function(i) i * 10 + (b %% 10)[i %% 100 == b %/% 10]))
}
zx8754_forloop <- function(a, b) {
res <- integer()
for(i in a) res <- c(res, i * 10 + (b %% 10)[i %% 100 == b %/% 10])
res
}
microbenchmark::microbenchmark(
zx8754 = zx8754(a, b),
zx8754_forloop = zx8754_forloop(a, b)
)
# Unit: microseconds
# expr min lq mean median uq max neval
# zx8754 16.535 17.3910 55.05348 17.676 18.246 3672.223 100
# zx8754_forloop 4.562 5.4165 46.74887 5.987 6.272 4080.469 100
#check output
identical(zx8754(a, b), zx8754_forloop(a, b))
# [1] TRUE
Ответ 7
Другой вариант - поместить его в столбцы и присоединиться:
library(data.table)
Frank <- function(a, b) {
aDT <- setDT(tstrsplit(a, ""))
bDT <- setnames(setDT(tstrsplit(b, "")), c("V2", "V3", "V4"))
merge(aDT, bDT, allow.cartesian = TRUE)[, paste0(V1, V2, V3, V4)]
}
или ответ @MattW в data.table:
MattDT <- function(a,b){
aDT2 <- data.table(V1 = substring(a,1,1), V23 = substring(a,2,3))
bDT2 <- data.table(V23 = substring(b,1,2), V4 = substring(b,3,3))
merge(aDT2, bDT2, allow.cartesian = TRUE)[, paste0(V1, V23, V4)]
}
Ответ 8
Вот пример, в котором этот список прошел:
result <- c()
for (ai in a) {
sub_ai <- substr(ai,2,3)
if (sub_ai %in% sub_a) {
b_match <- (sub_b == sub_ai)
result <- c(result,paste0(ai,substr(b[b_match],3,4)))
}
}
> result
[1] "1234" "1238" "2342" "4325" "4326" "2234" "2238"
Затем вы можете захотеть получить уникальные результаты.
Ответ 9
Использование dplyr:: inner_join на средних частях:
library(dplyr)
a <- c(123, 234, 432, 223)
b <- c(234, 238, 342, 325, 326)
a1 <- data.frame(a)
b1 <- data.frame(b)
a1 <- a1 %>% mutate(first_a = substr(a, 1, 1), last_a = substr(a, 2, 3))
b1 <- b1 %>% mutate(first_b = substr(b, 1, 2), last_b = substr(b, 3, 3))
c1 <- inner_join(a1, b1, by = c("last_a" = "first_b"))
results <- paste0(c1$a, c1$last_b)
Использование base:: merge:
a1 <- data.frame(a)
b1 <- data.frame(b)
a1$first_a = substr(a1$a, 1, 1)
a1$last_a = substr(a1$a, 2, 3)
b1$first_b = substr(b1$b, 1, 2)
b1$last_b = substr(b1$b, 3, 3)
c1 <- merge(a1, b1, by.x = "last_a", by.y = "first_b")
results <- paste0(c1$a, c1$last_b)
