Swap each value to a different value

Question

Below is the swapping function which swap values lesser than 10 in a list

swapFun <- function(x, n = 10){
inx <- which(x < n)
x[sample(inx)] <- x[inx]
x
}

For example, the original list is 1, 2, 3, 10, 4, 11.

After swapping by sampling , this list may be 2, 1, 4, 10, 3, 11 or 1, 3, 2, 10, 4, 11.

But I want to swap each value lesser than 10 to a different value lesser than 10.

For example, the first outcome (ie 2, 1, 4, 10, 3, 11) is what I want because each value lesser than 10 has been swapped to a different value lesser than 10.

However the second outcome (ie 1, 3, 2, 10, 4, 11.) is not what I want because 1 and 4 have not been swapped to a different value lesser than 10.

If there are no feasible solution, just print 'no feasible solution'

Any suggestions? Many thanks.

Answer 1

You are looking for a derangement of the values less than 10. By the theory of derangements, approximately 1/e (37%) of randomly chosen permutations are derangements, so a hit or miss approach is reasonable, with an important caveat.

There might be repetitions among the items less than n. Not all permutations of those items are distinguishable, so not all derangements of the items look like derangements: swapping two 2s with each other (for example) is in some sense a derangement, but it wouldn't look like a derangement. The 1/e heuristic applies to raw permutations of positions, not distinguishable permutations of values. If the number of repetitions is high, it might take longer than 1/e would suggest. If in your use-case the performance isn't satisfactory, you would need to replace sample() in the function definitions by a more sophisticated function that picks random distinguishable permutations.

As far as feasibility goes, there will be a feasible solution so long as the most common element less than n doesn't account for more than 50% of the items less than n

derangement <- function(x){
  if(max(table(x)) > length(x)/2) return(NA)
  while(TRUE){
    y <- sample(x)
    if(all(y != x)) return(y)
  }
}

swapFun <- function(x, n = 10){
  inx <- which(x < n)
  y <- derangement(x[inx])
  if(length(y) == 1) return(NA) 
  x[inx] <- y
  x
}

For example,

> set.seed(10)
> swapFun(c(1,2,10,4,11,2,12))
[1]  2  4 10  2 11  1 12
> swapFun(c(2,2,10,4,11,2,12))
[1] NA

Note that no valid derangement has length 1, but NA has length 1, so testing the length of y is an effective way to test if it is possible to derange the values. The function returns NA if no derangement of the values less than n exists. You can test for NA and print "No feasible solutions" if you want

Answer 2

This function gives you all the unique permutations for the numbers < m while keeping the positions of numbers >= m the same.

require(combinat)

x <- c(1,2,10,4,11,2,12)
m <- 10

swapFun <- function(x, m){

  # determine positions of values to be permutated or fixed
  xi <- which(x < m)
  xj <- which(x >= m)

  # make permuations
  xp <- do.call(rbind, permn(x[xi]))

  # make matrix with permutated and fixed values
  xn <- matrix(nrow = nrow(xp), ncol = length(x))
  xn[ ,xi] <- xp
  xn[ ,xj] <- sort(rep(x[xj],nrow(xp)))

  # delete duplicates
  d <- !duplicated(apply(xn, 1, paste, collapse = "_"))
  xn <- xn[d,]

  return(xn)
}

swapFun(x,m)

> swapFun(x,m)
        [,1] [,2] [,3] [,4] [,5] [,6] [,7]
 [1,]    1    2   10    4   11    2   12
 [2,]    1    2   10    2   11    4   12
 [3,]    2    1   10    2   11    4   12
 [4,]    2    1   10    4   11    2   12
 [5,]    1    4   10    2   11    2   12
 [6,]    4    1   10    2   11    2   12
 [7,]    4    2   10    1   11    2   12
 [8,]    2    4   10    1   11    2   12
 [9,]    2    4   10    2   11    1   12
[10,]    4    2   10    2   11    1   12
[11,]    2    2   10    4   11    1   12
[12,]    2    2   10    1   11    4   12