Сопоставьте подстроку двух векторов и создайте новый вектор, объединяющий их

Рассмотрим два вектора.

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)