Создайте все комбинации замещения букв в строке

У меня есть строка "ECET", и я хотел бы создать все возможные строки, где я заменю одну или несколько букв (все, кроме первой) на "X".

Поэтому в этом случае мой результат будет следующим:

> result
[1] "EXET" "ECXT" "ECEX" "EXXT" "EXEX" "ECXX" "EXXX"

Любые идеи относительно того, как подойти к проблеме?

Это не просто создает возможные комбинации/перестановки "X", но также и их объединение с существующей строкой.

Ответ 1

Использование аргумента FUN для combn:

a <- "ECET"

fun <- function(n, string) {
  combn(nchar(string), n, function(x) {
    s <- strsplit(string, '')[[1]]
    s[x] <- 'X'
    paste(s, collapse = '')
  } )
}
lapply(seq_len(nchar(a)), fun, string = a)

[[1]]
[1] "XCET" "EXET" "ECXT" "ECEX"

[[2]]
[1] "XXET" "XCXT" "XCEX" "EXXT" "EXEX" "ECXX"

[[3]]
[1] "XXXT" "XXEX" "XCXX" "EXXX"

[[4]]
[1] "XXXX"

unlist чтобы получить один вектор. Возможно, доступны более быстрые решения.

Чтобы оставить свой первый символ без изменений:

paste0(
  substring(a, 1, 1),
  unlist(lapply(seq_len(nchar(a) - 1), fun, string = substring(a, 2)))
)

[1] "EXET" "ECXT" "ECEX" "EXXT" "EXEX" "ECXX" "EXXX"

Ответ 2

Здесь рекурсивное решение:

f <- function(x,pos=2){
  if(pos <= nchar(x))
    c(f(x,pos+1), f('substr<-'(x, pos, pos, "X"),pos+1))
  else x
}
f(x)[-1]
# [1] "ECEX" "ECXT" "ECXX" "EXET" "EXEX" "EXXT" "EXXX"

Или с помощью expand.grid:

do.call(paste0, expand.grid(c(substr(x,1,1),lapply(strsplit(x,"")[[1]][-1], c, "X"))))[-1]
# [1] "EXET" "ECXT" "EXXT" "ECEX" "EXEX" "ECXX" "EXXX"

Или используя combn/Reduce/substr<-:

combs <- unlist(lapply(seq(nchar(x)-1),combn, x =seq(nchar(x))[-1],simplify = F),F)
sapply(combs, Reduce, f= function(x,y) 'substr<-'(x,y,y,"X"), init = x)
# [1] "EXET" "ECXT" "ECEX" "EXXT" "EXEX" "ECXX" "EXXX"

Второе объяснение

pairs0 <- lapply(strsplit(x,"")[[1]][-1], c, "X") # pairs of original letter + "X"
pairs1 <- c(substr(x,1,1), pairs0)                # including 1st letter (without "X")
do.call(paste0, expand.grid(pairs1))[-1]          # expand into data.frame and paste

Ответ 3

Вид для добавления другой опции с использованием двоичной логики:

Предполагая, что ваша строка имеет длину 4 символа:

input<-"ECET"
invec <- strsplit(input,'')[[1]]
sapply(1:7, function(x) {
  z <- invec
  z[rev(as.logical(intToBits(x))[1:4])] <- "X"
  paste0(z,collapse = '')
})

[1] "ECEX" "ECXT" "ECXX" "EXET" "EXEX" "EXXT" "EXXX"

Если строка должна быть длиннее, вы можете вычислить значения с мощностью 2, что-то вроде этого должно делать:

input<-"ECETC"
pow <- nchar(input)
invec <- strsplit(input,'')[[1]]
sapply(1:(2^(pow-1) - 1), function(x) {
  z <- invec
  z[rev(as.logical(intToBits(x))[1:(pow)])] <- "X"
  paste0(z,collapse = '')
})

[1] "ECETX" "ECEXC" "ECEXX" "ECXTC" "ECXTX" "ECXXC" "ECXXX" "EXETC" "EXETX" "EXEXC" "EXEXX" "EXXTC" "EXXTX" "EXXXC"
[15] "EXXXX"

Идея состоит в том, чтобы знать количество возможных изменений, это двоичный код из трех позиций, поэтому 2 ^ 3 минус 1, так как мы не хотим сохранить заменяющую строку: 7

intToBits возвращает двоичное значение целого числа, для 5:

> intToBits(5)
 [1] 01 00 01 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00

R по умолчанию использует 32 бита, но нам просто нужен логический вектор, соответствующий нашей длине строки, поэтому мы просто сохраняем nchar исходной строки. Затем мы преобразуем в логические и реверсируем эти 4 логических значения, так как мы никогда не будем запускать последний бит (8 для 4 символов), это никогда не будет правдой:

> intToBits(5)
 [1] 01 00 01 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00 00
> tmp<-as.logical(intToBits(5)[1:4])
> tmp
[1]  TRUE FALSE  TRUE FALSE
> rev(tmp)
[1] FALSE  TRUE FALSE  TRUE

Чтобы избежать перезаписи нашего исходного вектора, мы скопируем его в z, а затем просто заменим позицию в z, используя этот логический вектор.

Для приятного вывода мы возвращаем paste0 с коллапсом как ничто, чтобы воссоздать одну строку и получить вектор символов.

Ответ 4

Другая версия с combn, используя purrr:

s <- "ECET"
f <- function(x,y) {substr(x,y,y) <- "X"; x}
g <- function(x) purrr::reduce(x,f,.init=s)
unlist(purrr::map(1:(nchar(s)-1), function(x) combn(2:nchar(s),x,g)))

#[1] "EXET" "ECXT" "ECEX" "EXXT" "EXEX" "ECXX" "EXXX"

или без purrr:

s <- "ECET"
f <- function(x,y) {substr(x,y,y) <- "X"; x}
g <- function(x) Reduce(f,x,s)
unlist(lapply(1:(nchar(s)-1),function(x) combn(2:nchar(s),x,g)))

Ответ 5

Вот базовое решение R, но я нахожу его сложным, с 3 вложенными циклами.

replaceChar <- function(x, char = "X"){
  n <- nchar(x)
  res <- NULL
  for(i in seq_len(n)){
    cmb <- combn(n, i)
    r <- apply(cmb, 2, function(cc){
      y <- x
      for(k in cc)
        substr(y, k, k) <- char
      y
    })
    res <- c(res, r)
  }
  res
}

x <- "ECET"

replaceChar(x)
replaceChar(x, "Y")
replaceChar(paste0(x, x))

Ответ 6

Векторный метод с булевым индексированием:

permX <- function(text, replChar='X') {
    library(gtools)
    library(stringr)  
    # get TRUE/FALSE permutations for nchar(text)
    idx <- permutations(2, nchar(text),c(T,F), repeats.allowed = T)

    # we don't want the first character to be replaced
    idx <- idx[1:(nrow(idx)/2),]

    # split string into single chars
    chars <- str_split(text,'')

    # build data.frame with nrows(df) == nrows(idx)
    df = t(data.frame(rep(chars, nrow(idx))))

    # do replacing
    df[idx] <- replChar

    row.names(df) <- c()
    return(df)
}
permX('ECET')

[,1] [,2] [,3] [,4]  
[1,] "E"  "C"  "E"  "T"   
[2,] "E"  "C"  "E"  "X"  
[3,] "E"  "C"  "X"  "T"  
[4,] "E"  "C"  "X"  "X"  
[5,] "E"  "X"  "E"  "T"  
[6,] "E"  "X"  "E"  "X"  
[7,] "E"  "X"  "X"  "T"  
[8,] "E"  "X"  "X"  "X"

Ответ 7

Еще одно простое решение

# expand.grid to get all combinations of the input vectors, result in a matrix
m <- expand.grid( c('E'), 
                  c('C','X'), 
                  c('E','X'), 
                  c('T','X') )

# then, optionally, apply to paste the columns together
apply(m, 1, paste0, collapse='')[-1]

[1] "EXET" "ECXT" "EXXT" "ECEX" "EXEX" "ECXX" "EXXX"