Search code examples
arraysrcombinatoricspermute

Permutations of 3 elements within 6 positions: one equal neighbour

Taking into account the answers in this post Permutations of 3 elements within 6 positions, I think it's worth to open a new discussion about how ordering the elements.

The first condition was to have always sequences with alternate elements: 

#   Var1 Var2 Var3 Var4 Var5 Var6     V7
# 1    b    c    a    b    c    a bcabca
# 2    c    a    b    c    a    b cabcab
# 3    a    b    c    a    b    c abcabc
# 4    b    a    b    c    a    b babcab
# 5    c    b    c    a    b    c cbcabc
# 6    a    c    a    b    c    a acabca

However, the rest of the permutations could have value even if there is one coincidence of elements in like-neighbour restriction. For instance: 

    #   Var1 Var2 Var3 Var4 Var5 Var6 Coincidence  
    # 1    b    b    a    b    c    a     -->[bb]
    # 2    c    c    b    c    a    b     -->[cc] 
    # 3    a    b    c    a    a    c     -->[aa] 
    # 4    b    a    c    c    a    b     -->[cc]

Is it possible to use expand.grid for that too?

Solution

  • If it's "only one more", then I suggest the simplest way to allow it is to force it.

    Using the start from the previous question:

    r <- replicate(6, seq_len(length(abc)-1), simplify=FALSE)
r[[1]] <- c(r[[1]], length(abc))

    We now copy this single list (that is passed to expand.grid) and replace each of the 2nd through last elements with 0. Recall that we are using these numbers with cumsum to change from the previous value, so replacing 1:2 with 0 means that we are forcing the next element to be the same.

    rs <- lapply(seq_len(length(r)-1) + 1, function(i) { r[[i]] <- 0; r; })
#            ^^^^^^^^^^^^^^^^^^^^^^^^ or: seq_len(length(r))[-1]
str(rs[1:2])
# List of 2
#  $ :List of 6
#   ..$ : int [1:3] 1 2 3
#   ..$ : num 0             <--- the second letter will repeat
#   ..$ : int [1:2] 1 2
#   ..$ : int [1:2] 1 2
#   ..$ : int [1:2] 1 2
#   ..$ : int [1:2] 1 2
#  $ :List of 6
#   ..$ : int [1:3] 1 2 3
#   ..$ : int [1:2] 1 2
#   ..$ : num 0             <--- the third letter will repeat
#   ..$ : int [1:2] 1 2
#   ..$ : int [1:2] 1 2
#   ..$ : int [1:2] 1 2
### other rs's are similar

    We can verify that this works as we think it should:

    # rs[[1]] repeats the first 2
m <- t(apply(do.call(expand.grid, rs[[1]]), 1, cumsum) %% length(abc) + 1)
m[] <- abc[m]
head(as.data.frame(cbind(m, apply(m, 1, paste, collapse = ""))), n=3)
#   Var1 Var2 Var3 Var4 Var5 Var6     V7
# 1    b    b    c    a    b    c bbcabc
# 2    c    c    a    b    c    a ccabca
# 3    a    a    b    c    a    b aabcab

# rs[[3]] repeats the 3rd-4th
m <- t(apply(do.call(expand.grid, rs[[3]]), 1, cumsum) %% length(abc) + 1)
m[] <- abc[m]
head(as.data.frame(cbind(m, apply(m, 1, paste, collapse = ""))), n=3)
#   Var1 Var2 Var3 Var4 Var5 Var6     V7
# 1    b    c    a    a    b    c bcaabc
# 2    c    a    b    b    c    a cabbca
# 3    a    b    c    c    a    b abccab

    From here, let's automate it by putting all of these into one list and lapplying them.

    rs <- c(list(r), rs)
rets <- do.call(rbind.data.frame, c(stringsAsFactors=FALSE, lapply(rs, function(r) {
  m <- t(apply(do.call(expand.grid, r), 1, cumsum) %% length(abc) + 1)
  m[] <- abc[m]
  as.data.frame(cbind(m, apply(m, 1, paste, collapse = "")), stringsAsFactors=FALSE)
})))
head(rets)
#   Var1 Var2 Var3 Var4 Var5 Var6     V7
# 1    b    c    a    b    c    a bcabca
# 2    c    a    b    c    a    b cabcab
# 3    a    b    c    a    b    c abcabc
# 4    b    a    b    c    a    b babcab
# 5    c    b    c    a    b    c cbcabc
# 6    a    c    a    b    c    a acabca
tail(rets)
#     Var1 Var2 Var3 Var4 Var5 Var6     V7
# 331    b    c    b    a    c    c bcbacc
# 332    c    a    c    b    a    a cacbaa
# 333    a    b    a    c    b    b abacbb
# 334    b    a    c    b    a    a bacbaa
# 335    c    b    a    c    b    b cbacbb
# 336    a    c    b    a    c    c acbacc

    Walkthrough of additional steps:

    • rs <- c(list(r), rs) makes the first (non-repeating r) an enclosed list, then prepends it to the rs list.
    • lapply(rs, function(r) ...) does the ... from the previous question once for each element in the rs list. I named it r inside the anon-function to make it perfectly clear (inside the function) that each time it gets a new r, it does exactly the same steps as the last question.
    • do.call(rbind.data.frame, c(stringsAsFactors=FALSE, ... because each return from the lapply will be a data.frame, and we want to combine them into a single frame. I prefer no factors, but you can choose otherwise if you need. (Instead of rbind.data.frame, you could use data.table::rbindlist or dplyr::bind_rows, both without stringsAsFactors.)

    Now the first 96 rows have no repeats, then the remaining five batches of 48 rows each (total 336 rows) have one repeat each. We "know" that 48 is the right number for each of the repeat-once lists, since by changing one of the positions from "1 2" possible to "0" (from 2 to 1 possible value) we halve the total number of possible combinations (96 / 2 == 48).

    If for some reason your next question asks how to expand this to allow two repeats ... then I wouldn't necessarily recommend brute-forcing this aspect of it: there are 6 or 10 possible combinations (depending on if "aaa" is allowed) of repeats, and I would much prefer to go to a more programmatic handling than this brute-force appending of the one-constraint.